husk-scheme 3.0 → 3.1
raw patch · 8 files changed
+991/−672 lines, 8 files
Files
- README.markdown +2/−2
- hs-src/Language/Scheme/Core.hs +238/−531
- hs-src/Language/Scheme/Macro.hs +186/−103
- hs-src/Language/Scheme/Primitives.hs +459/−0
- hs-src/Language/Scheme/Variables.hs +19/−12
- hs-src/shell.hs +1/−1
- husk-scheme.cabal +4/−2
- stdlib.scm +82/−21
README.markdown view
@@ -1,6 +1,6 @@  -husk is a dialect of Scheme written in Haskell that implements a subset of the [R<sup>5</sup>RS standard](http://www.schemers.org/Documents/Standards/R5RS/HTML/). Advanced R<sup>5</sup>RS features are provided including continuations, hygienic macros, and a full numeric tower.+husk is a dialect of Scheme written in Haskell that implements a subset of the [R<sup>5</sup>RS standard](http://www.schemers.org/Documents/Standards/R5RS/HTML/). Advanced R<sup>5</sup>RS features are provided including continuations, non-hygienic macros, and a full numeric tower. husk provides many features and is intended as a good choice for non-performance critical applications, as it is not a highly optimized Scheme. Rather, the goal of the project is to provide a tight integration between Haskell and Scheme while at the same time providing an opportunity for deeper understanding of both languages. In addition, by closely following the R<sup>5</sup>RS standard, the intent is to develop a Scheme that is as compatible as possible with other R<sup>5</sup>RS Schemes. @@ -25,7 +25,7 @@ - Read-Eval-Print-Loop (REPL) interpreter, with input driven by Haskeline to provide a rich user experience - Full numeric tower: includes support for parsing/storing types (exact, inexact, etc), support for operations on these types as well as mixing types and other constraints from the R<sup>5</sup>RS specification. - Continuations: First-class continuations, call/cc, and call-with-values.-- Hygienic Macros: High-level macros via define-syntax - *Note this is still somewhat of a 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.+- Non-hygienic Macros: High-level macros via define-syntax - *Note this is still somewhat of a 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. As well as the following approved extensions:
hs-src/Language/Scheme/Core.hs view
@@ -25,21 +25,19 @@ import Language.Scheme.Macro import Language.Scheme.Numerical import Language.Scheme.Parser+import Language.Scheme.Primitives import Language.Scheme.Types import Language.Scheme.Variables import Control.Monad.Error-import Char import Data.Array import qualified Data.Map import IO hiding (try)-import System.Directory (doesFileExist)-import System.IO.Error import qualified GHC import qualified GHC.Paths (libdir) import qualified DynFlags import qualified Unsafe.Coerce (unsafeCoerce)--- import Debug.Trace+--import Debug.Trace {- |Evaluate a string containing Scheme code. @@ -108,8 +106,8 @@ -- Pass extra args along if last expression of a function, to support (call-with-values) continueEval nEnv (Continuation nEnv ncCont nnCont extraArgs nDynWind) val _ -> return (val)- [lv] -> eval cEnv (Continuation cEnv (Just (SchemeBody [])) (Just cCont) Nothing dynWind) (lv)- (lv : lvs) -> eval cEnv (Continuation cEnv (Just (SchemeBody lvs)) (Just cCont) Nothing dynWind) (lv)+ [lv] -> macroEval cEnv lv >>= eval cEnv (Continuation cEnv (Just (SchemeBody [])) (Just cCont) Nothing dynWind)+ (lv : lvs) -> macroEval cEnv lv >>= eval cEnv (Continuation cEnv (Just (SchemeBody lvs)) (Just cCont) Nothing dynWind) -- No current continuation, but a next cont is available; call into it continueEval _ (Continuation cEnv Nothing (Just cCont) _ _) val = continueEval cEnv cCont val@@ -176,7 +174,7 @@ where cpsUnquote :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsUnquote e c val _ = do case val of- List [Atom "unquote", vval] -> eval e c vval+ List [Atom "unquote", vval] -> macroEval e vval >>= eval e c List (_ : _) -> doCpsUnquoteList e c val DottedList xs x -> do doCpsUnquoteList e (makeCPSWArgs e c cpsUnquotePair $ [x] ) $ List xs@@ -185,7 +183,7 @@ if len > 0 then doCpsUnquoteList e (makeCPS e c cpsUnquoteVector) $ List $ elems vec else continueEval e c $ Vector $ listArray (0, -1) []- _ -> eval e c (List [Atom "quote", val]) -- Behave like quote if there is nothing to "unquote"...+ _ -> macroEval e (List [Atom "quote", val]) >>= eval e c -- Behave like quote if there is nothing to "unquote"... {- Unquote a pair This must be started by unquoting the "left" hand side of the pair,@@ -221,7 +219,7 @@ cpsUnquoteList e c val (Just ([List unEvaled, List acc])) = do case val of List [Atom "unquote-splicing", vvar] -> do- eval e (makeCPSWArgs e c cpsUnquoteSplicing $ [List unEvaled, List acc]) vvar+ macroEval e vvar >>= eval e (makeCPSWArgs e c cpsUnquoteSplicing $ [List unEvaled, List acc]) _ -> cpsUnquote e (makeCPSWArgs e c cpsUnquoteFld $ [List unEvaled, List acc]) val Nothing cpsUnquoteList _ _ _ _ = throwError $ InternalError "Unexpected parameters to cpsUnquoteList" @@ -243,35 +241,47 @@ _ -> cpsUnquoteList e c (head unEvaled) (Just [List (tail unEvaled), List $ acc ++ [val] ]) cpsUnquoteFld _ _ _ _ = throwError $ InternalError "Unexpected parameters to cpsUnquoteFld" -eval env cont (List [Atom "if", predic, conseq, alt]) = do- eval env (makeCPS env cont cps) (predic)- where cps :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal- cps e c result _ =+eval env cont args@(List [Atom "if", predic, conseq, alt]) = do+ bound <- liftIO $ isBound env "if"+ if bound+ then prepareApply env cont args -- if is bound to a variable in this scope; call into it+ else macroEval env predic >>= eval env (makeCPS env cont cps)+ where cps :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal+ cps e c result _ = case (result) of- Bool False -> eval e c alt- _ -> eval e c conseq+ Bool False -> macroEval e alt >>= eval e c+ _ -> macroEval e conseq >>= eval e c -eval env cont (List [Atom "if", predic, conseq]) =- eval env (makeCPS env cont cpsResult) predic- where cpsResult :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal- cpsResult e c result _ =+eval env cont args@(List [Atom "if", predic, conseq]) = do+ bound <- liftIO $ isBound env "if"+ if bound+ then prepareApply env cont args -- if is bound to a variable in this scope; call into it+ else macroEval env predic >>= eval env (makeCPS env cont cpsResult)+ where cpsResult :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal+ cpsResult e c result _ = case result of- Bool True -> eval e c conseq+ Bool True -> macroEval e conseq >>= eval e c _ -> continueEval e c $ Nil "" -- Unspecified return value per R5RS --- FUTURE: convert cond to a derived form (scheme macro)-eval env cont (List (Atom "cond" : clauses)) =- if length clauses == 0- then throwError $ BadSpecialForm "No matching clause" $ String "cond"- else do- case (clauses !! 0) of- List [test, Atom "=>", expr] -> eval env (makeCPSWArgs env cont cpsAlt [test]) expr- List (Atom "else" : _) -> eval env (makeCPSWArgs env cont cpsResult clauses) $ Bool True- List (cond : _) -> eval env (makeCPSWArgs env cont cpsResult clauses) cond- badType -> throwError $ TypeMismatch "clause" badType+{- OBSOLETE:+-- TODO: convert cond to a derived form (scheme macro)+-- TODO: is the 'bound' code below good enough? need to test w/else redefined.+-- if not good enough, may just need to go all the way and rewrite all of this as a macro!+eval env cont args@(List (Atom "cond" : clauses)) = do+ bound <- liftIO $ isBound env "cond"+ if bound+ then prepareApply env cont args -- if is bound to a variable in this scope; call into it+ else if length clauses == 0+ then throwError $ BadSpecialForm "No matching clause" $ String "cond"+ else do+ case (clauses !! 0) of+ List [test, Atom "=>", expr] -> eval env (makeCPSWArgs env cont cpsAlt [test]) expr+ List (Atom "else" : _) -> eval env (makeCPSWArgs env cont cpsResult clauses) $ Bool True+ List (cond : _) -> eval env (makeCPSWArgs env cont cpsResult clauses) cond+ badType -> throwError $ TypeMismatch "clause" badType where- {- If a condition is true, evaluate that condition's expressions.- Otherwise just pick up at the next condition... -}+ { - If a condition is true, evaluate that condition's expressions.+ Otherwise just pick up at the next condition... - } cpsResult :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsResult e cnt result (Just (c : cs)) = case result of@@ -294,56 +304,92 @@ cpsAltEvaled :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsAltEvaled _ c test (Just [expr]) = apply c expr [test] cpsAltEvaled _ _ _ _ = throwError $ Default "Unexpected error in cond"+-} -eval env cont (List (Atom "begin" : funcs)) =- if length funcs == 0- then eval env cont $ Nil ""- else if length funcs == 1- then eval env cont (head funcs)- else eval env (makeCPSWArgs env cont cpsRest $ tail funcs) (head funcs)+eval env cont fargs@(List (Atom "begin" : funcs)) = do+ bound <- liftIO $ isBound env "begin"+ if bound+ then prepareApply env cont fargs -- if is bound to a variable in this scope; call into it+ else if length funcs == 0+ then macroEval env (Nil "") >>= eval env cont+ else if length funcs == 1+ then macroEval env (head funcs) >>= eval env cont + else macroEval env (head funcs) >>= eval env (makeCPSWArgs env cont cpsRest $ tail funcs) where cpsRest :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsRest e c _ args = case args of- Just fArgs -> eval e c $ List (Atom "begin" : fArgs)+ Just fArgs -> macroEval e (List (Atom "begin" : fArgs)) >>= eval e c Nothing -> throwError $ Default "Unexpected error in begin" -eval env cont (List [Atom "set!", Atom var, form]) = do- eval env (makeCPS env cont cpsResult) form+eval env cont args@(List [Atom "set!", Atom var, form]) = do+ bound <- liftIO $ isBound env "set!"+ if bound+ then prepareApply env cont args -- if is bound to a variable in this scope; call into it+ else macroEval env form >>= eval env (makeCPS env cont cpsResult) where cpsResult :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsResult e c result _ = setVar e var result >>= continueEval e c-eval _ _ (List [Atom "set!", nonvar, _]) = throwError $ TypeMismatch "variable" nonvar-eval _ _ (List (Atom "set!" : args)) = throwError $ NumArgs 2 args+eval env cont args@(List [Atom "set!", nonvar, _]) = do + bound <- liftIO $ isBound env "set!"+ if bound+ then prepareApply env cont args -- if is bound to a variable in this scope; call into it+ else throwError $ TypeMismatch "variable" nonvar+eval env cont fargs@(List (Atom "set!" : args)) = do+ bound <- liftIO $ isBound 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 -eval env cont (List [Atom "define", Atom var, form]) = do- eval env (makeCPS env cont cpsResult) form+eval env cont args@(List [Atom "define", Atom var, form]) = do+ bound <- liftIO $ isBound env "define"+ if bound+ then prepareApply env cont args -- if is bound to a variable in this scope; call into it+ else macroEval env form >>= eval env (makeCPS env cont cpsResult) where cpsResult :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsResult e c result _ = defineVar e var result >>= continueEval e c -eval env cont (List (Atom "define" : List (Atom var : fparams) : fbody )) = do- result <- (makeNormalFunc env fparams fbody >>= defineVar env var)- continueEval env cont result+eval env cont args@(List (Atom "define" : List (Atom var : fparams) : fbody )) = do+ bound <- liftIO $ isBound 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 -eval env cont (List (Atom "define" : DottedList (Atom var : fparams) varargs : fbody)) = do- result <- (makeVarargs varargs 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 $ isBound env "define"+ if bound+ then prepareApply env cont args -- if is bound to a variable in this scope; call into it+ else do result <- (makeVarargs varargs env fparams fbody >>= defineVar env var)+ continueEval env cont result -eval env cont (List (Atom "lambda" : List fparams : fbody)) = do- result <- makeNormalFunc env fparams fbody- continueEval env cont result+eval env cont args@(List (Atom "lambda" : List fparams : fbody)) = do+ bound <- liftIO $ isBound env "lambda"+ 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+ continueEval env cont result -eval env cont (List (Atom "lambda" : DottedList fparams varargs : fbody)) = do- result <- makeVarargs varargs env fparams fbody- continueEval env cont result+eval env cont args@(List (Atom "lambda" : DottedList fparams varargs : fbody)) = do+ bound <- liftIO $ isBound env "lambda"+ if bound+ then prepareApply env cont args -- if is bound to a variable in this scope; call into it+ else do result <- makeVarargs varargs env fparams fbody+ continueEval env cont result -eval env cont (List (Atom "lambda" : varargs@(Atom _) : fbody)) = do- result <- makeVarargs varargs env [] fbody- continueEval env cont result+eval env cont args@(List (Atom "lambda" : varargs@(Atom _) : fbody)) = do+ bound <- liftIO $ isBound env "lambda"+ if bound+ then prepareApply env cont args -- if is bound to a variable in this scope; call into it+ else do result <- makeVarargs varargs env [] fbody+ continueEval env cont result -eval env cont (List [Atom "string-set!", Atom var, i, character]) = do- eval env (makeCPS env cont cpsStr) i- where+eval env cont args@(List [Atom "string-set!", Atom var, i, character]) = do+ bound <- liftIO $ isBound env "string-set!"+ if bound+ then prepareApply env cont args -- if is bound to a variable in this scope; call into it+ else macroEval env i >>= eval env (makeCPS env cont cpsStr)+ where cpsStr :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal- cpsStr e c idx _ = eval e (makeCPSWArgs e c cpsSubStr $ [idx]) =<< getVar e var+ cpsStr e c idx _ = (macroEval e =<< getVar e var) >>= eval e (makeCPSWArgs e c cpsSubStr $ [idx]) cpsSubStr :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsSubStr e c str (Just [idx]) =@@ -357,49 +403,82 @@ substr (String _, Char _, n) = throwError $ TypeMismatch "number" n substr (String _, c, _) = throwError $ TypeMismatch "character" c substr (s, _, _) = throwError $ TypeMismatch "string" s-eval _ _ (List [Atom "string-set!" , nonvar , _ , _ ]) = throwError $ TypeMismatch "variable" nonvar-eval _ _ (List (Atom "string-set!" : args)) = throwError $ NumArgs 3 args+eval env cont args@(List [Atom "string-set!" , nonvar , _ , _ ]) = do+ bound <- liftIO $ isBound env "string-set!"+ if bound+ then prepareApply env cont args -- if is bound to a variable in this scope; call into it+ else throwError $ TypeMismatch "variable" nonvar+eval env cont fargs@(List (Atom "string-set!" : args)) = do + bound <- liftIO $ isBound 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 -eval env cont (List [Atom "set-car!", Atom var, argObj]) = do- continueEval env (makeCPS env cont cpsObj) =<< getVar env var- where+eval env cont args@(List [Atom "set-car!", Atom var, argObj]) = do+ bound <- liftIO $ isBound env "set-car!"+ if bound+ then prepareApply env cont args -- if is bound to a variable in this scope; call into it+ else continueEval env (makeCPS env cont cpsObj) =<< getVar env var+ where cpsObj :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsObj _ _ obj@(List []) _ = throwError $ TypeMismatch "pair" obj- cpsObj e c obj@(List (_ : _)) _ = eval e (makeCPSWArgs e c cpsSet $ [obj]) argObj- cpsObj e c obj@(DottedList _ _) _ = eval e (makeCPSWArgs e c cpsSet $ [obj]) argObj+ cpsObj e c obj@(List (_ : _)) _ = macroEval e argObj >>= eval e (makeCPSWArgs e c cpsSet $ [obj])+ cpsObj e c obj@(DottedList _ _) _ = macroEval e argObj >>= eval e (makeCPSWArgs e c cpsSet $ [obj]) cpsObj _ _ obj _ = throwError $ TypeMismatch "pair" obj cpsSet :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsSet e c obj (Just [List (_ : ls)]) = setVar e var (List (obj : ls)) >>= continueEval e c -- Wrong constructor? Should it be DottedList? cpsSet e c obj (Just [DottedList (_ : ls) l]) = setVar e var (DottedList (obj : ls) l) >>= continueEval e c cpsSet _ _ _ _ = throwError $ InternalError "Unexpected argument to cpsSet"-eval _ _ (List [Atom "set-car!" , nonvar , _ ]) = throwError $ TypeMismatch "variable" nonvar-eval _ _ (List (Atom "set-car!" : args)) = throwError $ NumArgs 2 args+eval env cont args@(List [Atom "set-car!" , nonvar , _ ]) = do+ bound <- liftIO $ isBound env "set-car!"+ if bound+ then prepareApply env cont args -- if is bound to a variable in this scope; call into it+ else throwError $ TypeMismatch "variable" nonvar+eval env cont fargs@(List (Atom "set-car!" : args)) = do+ bound <- liftIO $ isBound 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 -eval env cont (List [Atom "set-cdr!", Atom var, argObj]) = do- continueEval env (makeCPS env cont cpsObj) =<< getVar env var- where+eval env cont args@(List [Atom "set-cdr!", Atom var, argObj]) = do+ bound <- liftIO $ isBound env "set-cdr!"+ if bound+ then prepareApply env cont args -- if is bound to a variable in this scope; call into it+ else continueEval env (makeCPS env cont cpsObj) =<< getVar env var+ where cpsObj :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsObj _ _ pair@(List []) _ = throwError $ TypeMismatch "pair" pair- cpsObj e c pair@(List (_ : _)) _ = eval e (makeCPSWArgs e c cpsSet $ [pair]) argObj- cpsObj e c pair@(DottedList _ _) _ = eval e (makeCPSWArgs e c cpsSet $ [pair]) argObj+ cpsObj e c pair@(List (_ : _)) _ = macroEval e argObj >>= eval e (makeCPSWArgs e c cpsSet $ [pair])+ cpsObj e c pair@(DottedList _ _) _ = macroEval e argObj >>= eval e (makeCPSWArgs e c cpsSet $ [pair]) cpsObj _ _ pair _ = throwError $ TypeMismatch "pair" pair cpsSet :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsSet e c obj (Just [List (l : _)]) = setVar e var (DottedList [l] obj) >>= continueEval e c cpsSet e c obj (Just [DottedList (l : _) _]) = setVar e var (DottedList [l] obj) >>= continueEval e c cpsSet _ _ _ _ = throwError $ InternalError "Unexpected argument to cpsSet"-eval _ _ (List [Atom "set-cdr!" , nonvar , _ ]) = throwError $ TypeMismatch "variable" nonvar-eval _ _ (List (Atom "set-cdr!" : args)) = throwError $ NumArgs 2 args+eval env cont args@(List [Atom "set-cdr!" , nonvar , _ ]) = do+ bound <- liftIO $ isBound env "set-cdr!"+ if bound+ then prepareApply env cont args -- if is bound to a variable in this scope; call into it+ else throwError $ TypeMismatch "variable" nonvar+eval env cont fargs@(List (Atom "set-cdr!" : args)) = do+ bound <- liftIO $ isBound 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 -eval env cont (List [Atom "vector-set!", Atom var, i, object]) = do- eval env (makeCPS env cont cpsObj) i- where+eval env cont args@(List [Atom "vector-set!", Atom var, i, object]) = do+ bound <- liftIO $ isBound env "vector-set!"+ if bound+ then prepareApply env cont args -- if is bound to a variable in this scope; call into it+ else macroEval env i >>= eval env (makeCPS env cont cpsObj)+ where cpsObj :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal- cpsObj e c idx _ = eval e (makeCPSWArgs e c cpsVec $ [idx]) object+ cpsObj e c idx _ = macroEval e object >>= eval e (makeCPSWArgs e c cpsVec $ [idx]) cpsVec :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal- cpsVec e c obj (Just [idx]) = eval e (makeCPSWArgs e c cpsUpdateVec $ [idx, obj]) =<< getVar e var+ cpsVec e c obj (Just [idx]) = (macroEval e =<< getVar e var) >>= eval e (makeCPSWArgs e c cpsUpdateVec $ [idx, obj]) cpsVec _ _ _ _ = throwError $ InternalError "Invalid argument to cpsVec" cpsUpdateVec :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal@@ -410,56 +489,90 @@ updateVector :: LispVal -> LispVal -> LispVal -> IOThrowsError LispVal updateVector (Vector vec) (Number idx) obj = return $ Vector $ vec // [(fromInteger idx, obj)] updateVector v _ _ = throwError $ TypeMismatch "vector" v-eval _ _ (List [Atom "vector-set!" , nonvar , _ , _]) = throwError $ TypeMismatch "variable" nonvar-eval _ _ (List (Atom "vector-set!" : args)) = throwError $ NumArgs 3 args+eval env cont args@(List [Atom "vector-set!" , nonvar , _ , _]) = do + bound <- liftIO $ isBound env "vector-set!"+ if bound+ then prepareApply env cont args -- if is bound to a variable in this scope; call into it+ else throwError $ TypeMismatch "variable" nonvar+eval env cont fargs@(List (Atom "vector-set!" : args)) = do + bound <- liftIO $ isBound 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 -eval env cont (List [Atom "hash-table-set!", Atom var, rkey, rvalue]) = do- eval env (makeCPS env cont cpsValue) rkey- where+eval env cont args@(List [Atom "hash-table-set!", Atom var, rkey, rvalue]) = do+ bound <- liftIO $ isBound env "hash-table-set!"+ if bound+ then prepareApply env cont args -- if is bound to a variable in this scope; call into it+ else macroEval env rkey >>= eval env (makeCPS env cont cpsValue)+ where cpsValue :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal- cpsValue e c key _ = eval e (makeCPSWArgs e c cpsH $ [key]) rvalue+ cpsValue e c key _ = macroEval e rvalue >>= eval e (makeCPSWArgs e c cpsH $ [key]) cpsH :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal- cpsH e c value (Just [key]) = eval e (makeCPSWArgs e c cpsEvalH $ [key, value]) =<< getVar e var+ cpsH e c value (Just [key]) = (macroEval e =<< getVar e var) >>= eval e (makeCPSWArgs e c cpsEvalH $ [key, value]) cpsH _ _ _ _ = throwError $ InternalError "Invalid argument to cpsH" cpsEvalH :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsEvalH e c h (Just [key, value]) = do case h of HashTable ht -> do- setVar env var (HashTable $ Data.Map.insert key value ht) >>= eval e c+ setVar env var (HashTable $ Data.Map.insert key value ht) >>= macroEval e >>= eval e c other -> throwError $ TypeMismatch "hash-table" other cpsEvalH _ _ _ _ = throwError $ InternalError "Invalid argument to cpsEvalH"-eval _ _ (List [Atom "hash-table-set!" , nonvar , _ , _]) = throwError $ TypeMismatch "variable" nonvar-eval _ _ (List (Atom "hash-table-set!" : args)) = throwError $ NumArgs 3 args+eval env cont args@(List [Atom "hash-table-set!" , nonvar , _ , _]) = do+ bound <- liftIO $ isBound env "hash-table-set!"+ if bound+ then prepareApply env cont args -- if is bound to a variable in this scope; call into it+ else throwError $ TypeMismatch "variable" nonvar+eval env cont fargs@(List (Atom "hash-table-set!" : args)) = do+ bound <- liftIO $ isBound 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 -eval env cont (List [Atom "hash-table-delete!", Atom var, rkey]) = do- eval env (makeCPS env cont cpsH) rkey- where+eval env cont args@(List [Atom "hash-table-delete!", Atom var, rkey]) = do+ bound <- liftIO $ isBound env "hash-table-delete!"+ if bound+ then prepareApply env cont args -- if is bound to a variable in this scope; call into it+ else macroEval env rkey >>= eval env (makeCPS env cont cpsH)+ where cpsH :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal- cpsH e c key _ = eval e (makeCPSWArgs e c cpsEvalH $ [key]) =<< getVar e var+ cpsH e c key _ = (macroEval e =<< getVar e var) >>= eval e (makeCPSWArgs e c cpsEvalH $ [key]) cpsEvalH :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsEvalH e c h (Just [key]) = do case h of HashTable ht -> do- setVar env var (HashTable $ Data.Map.delete key ht) >>= eval e c+ setVar env var (HashTable $ Data.Map.delete key ht) >>= macroEval e >>= eval e c other -> throwError $ TypeMismatch "hash-table" other cpsEvalH _ _ _ _ = throwError $ InternalError "Invalid argument to cpsEvalH"-eval _ _ (List [Atom "hash-table-delete!" , nonvar , _]) = throwError $ TypeMismatch "variable" nonvar-eval _ _ (List (Atom "hash-table-delete!" : args)) = throwError $ NumArgs 2 args+eval env cont args@(List [Atom "hash-table-delete!" , nonvar , _]) = do+ bound <- liftIO $ isBound env "hash-table-delete!"+ if bound+ then prepareApply env cont args -- if is bound to a variable in this scope; call into it+ else throwError $ TypeMismatch "variable" nonvar+eval env cont fargs@(List (Atom "hash-table-delete!" : args)) = do+ bound <- liftIO $ isBound 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 -{- Call a function by evaluating its arguments and then-executing it via 'apply'. -}-eval env cont (List (function : functionArgs)) = do+eval env cont args@(List (_ : _)) = macroEval env args >>= prepareApply env cont+eval _ _ badForm = throwError $ BadSpecialForm "Unrecognized special form" badForm++{- Prepare for apply by evaluating each function argument,+ and then execute the function via 'apply' -}+prepareApply :: Env -> LispVal -> LispVal -> IOThrowsError LispVal+prepareApply env cont (List (function : functionArgs)) = do eval env (makeCPSWArgs env cont cpsPrepArgs $ functionArgs) function where cpsPrepArgs :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsPrepArgs e c func (Just args) = -- case (trace ("prep eval of args: " ++ show args) args) of case (args) of [] -> apply c func [] -- No args, immediately apply the function- [a] -> eval env (makeCPSWArgs e c cpsEvalArgs $ [func, List [], List []]) a- (a : as) -> eval env (makeCPSWArgs e c cpsEvalArgs $ [func, List [], List as]) a+ [a] -> macroEval env a >>= eval env (makeCPSWArgs e c cpsEvalArgs $ [func, List [], List []])+ (a : as) -> macroEval env a >>= eval env (makeCPSWArgs e c cpsEvalArgs $ [func, List [], List as]) cpsPrepArgs _ _ _ Nothing = throwError $ Default "Unexpected error in function application (1)" {- Store value of previous argument, evaluate the next arg until all are done parg - Previous argument that has now been evaluated@@ -471,13 +584,12 @@ cpsEvalArgs e c evaledArg (Just [func, List argsEvaled, List argsRemaining]) = case argsRemaining of [] -> apply c func (argsEvaled ++ [evaledArg])- [a] -> eval e (makeCPSWArgs e c cpsEvalArgs $ [func, List (argsEvaled ++ [evaledArg]), List []]) a- (a : as) -> eval e (makeCPSWArgs e c cpsEvalArgs $ [func, List (argsEvaled ++ [evaledArg]), List as]) a+ [a] -> macroEval e a >>= eval e (makeCPSWArgs e c cpsEvalArgs $ [func, List (argsEvaled ++ [evaledArg]), List []])+ (a : as) -> macroEval e a >>= eval e (makeCPSWArgs e c cpsEvalArgs $ [func, List (argsEvaled ++ [evaledArg]), List as]) cpsEvalArgs _ _ _ (Just _) = throwError $ Default "Unexpected error in function application (1)" cpsEvalArgs _ _ _ Nothing = throwError $ Default "Unexpected error in function application (2)"--eval _ _ badForm = throwError $ BadSpecialForm "Unrecognized special form" badForm+prepareApply _ _ _ = throwError $ Default "Unexpected error in prepareApply" makeFunc :: -- forall (m :: * -> *). (Monad m) =>@@ -574,16 +686,6 @@ {- These functions have access to the current environment via the current continuation, which is passed as the first LispVal argument. -} ---evalFunctions :: [(String, [LispVal] -> IOThrowsError LispVal)]-evalFunctions = [- ("apply", evalfuncApply)- , ("call-with-current-continuation", evalfuncCallCC)- , ("call-with-values", evalfuncCallWValues)- , ("dynamic-wind", evalfuncDynamicWind)- , ("eval", evalfuncEval)- , ("load", evalfuncLoad)- , ("load-ffi", evalfuncLoadFFI) -- Non-standard extension- ] evalfuncApply, evalfuncDynamicWind, evalfuncEval, evalfuncLoad, evalfuncLoadFFI, evalfuncCallCC, evalfuncCallWValues :: [LispVal] -> IOThrowsError LispVal {-@@ -700,7 +802,7 @@ -- -- FUTURE: consider allowing env to be specified, per R5RS ---evalfuncEval [cont@(Continuation env _ _ _ _), val] = eval env cont val+evalfuncEval [cont@(Continuation env _ _ _ _), val] = macroEval env val >>= eval env cont evalfuncEval (_ : args) = throwError $ NumArgs 1 args -- Skip over continuation argument evalfuncEval _ = throwError $ NumArgs 1 [] @@ -719,6 +821,17 @@ evalfuncCallCC (_ : args) = throwError $ NumArgs 1 args -- Skip over continuation argument evalfuncCallCC _ = throwError $ NumArgs 1 [] +{- Primitive functions that extend the core evaluator -}+evalFunctions :: [(String, [LispVal] -> IOThrowsError LispVal)]+evalFunctions = [+ ("apply", evalfuncApply)+ , ("call-with-current-continuation", evalfuncCallCC)+ , ("call-with-values", evalfuncCallWValues)+ , ("dynamic-wind", evalfuncDynamicWind)+ , ("eval", evalfuncEval)+ , ("load", evalfuncLoad)+ , ("load-ffi", evalfuncLoadFFI) -- Non-standard extension+ ] {- I/O primitives Primitive functions that execute within the IO monad -} ioPrimitives :: [(String, [LispVal] -> IOThrowsError LispVal)]@@ -752,99 +865,10 @@ String str -> hPutStr port str _ -> hPutStr port $ show obj)), ("read-contents", readContents),- ("read-all", readAll)]--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--closePort :: [LispVal] -> IOThrowsError LispVal-closePort [Port port] = liftIO $ hClose port >> (return $ Bool True)-closePort _ = return $ Bool False--currentInputPort, currentOutputPort :: [LispVal] -> IOThrowsError LispVal-{- FUTURE: For now, these are just hardcoded to the standard i/o ports.-a future implementation that includes with-*put-from-file-would require a more involved implementation here as well as-other I/O functions hooking into these instead of std* -}-currentInputPort _ = return $ Port stdin-currentOutputPort _ = return $ Port stdout--isInputPort, isOutputPort :: [LispVal] -> IOThrowsError LispVal-isInputPort [Port port] = liftM Bool $ liftIO $ hIsReadable port-isInputPort _ = return $ Bool False--isOutputPort [Port port] = liftM Bool $ liftIO $ hIsWritable port-isOutputPort _ = return $ Bool False--readProc :: [LispVal] -> IOThrowsError LispVal-readProc [] = readProc [Port stdin]-readProc [Port port] = do- input <- liftIO $ try (liftIO $ hGetLine port)- case input of- Left e -> if isEOFError e- then return $ EOF- else throwError $ Default "I/O error reading from port" -- FUTURE: ioError e- Right inpStr -> do- liftThrows $ readExpr inpStr-readProc args@(_ : _) = throwError $ BadSpecialForm "" $ List args--readCharProc :: (Handle -> IO Char) -> [LispVal] -> IOThrowsError LispVal-readCharProc func [] = readCharProc func [Port stdin]-readCharProc func [Port port] = do- liftIO $ hSetBuffering port NoBuffering- input <- liftIO $ try (liftIO $ func port)- liftIO $ hSetBuffering port LineBuffering- case input of- Left e -> if isEOFError e- then return $ EOF- else throwError $ Default "I/O error reading from port"- Right inpChr -> do- return $ Char inpChr-readCharProc _ args@(_ : _) = throwError $ BadSpecialForm "" $ List args--{- writeProc :: --forall a (m :: * -> *).- (MonadIO m, MonadError LispError m) =>- (Handle -> LispVal -> IO a) -> [LispVal] -> m LispVal -}-writeProc func [obj] = writeProc func [obj, Port stdout]-writeProc func [obj, Port port] = do- output <- liftIO $ try (liftIO $ func port obj)- case output of- Left _ -> throwError $ Default "I/O error writing to port"- Right _ -> return $ Nil ""-writeProc _ other = if length other == 2- then throwError $ TypeMismatch "(value port)" $ List other- else throwError $ NumArgs 2 other--writeCharProc :: [LispVal] -> IOThrowsError LispVal-writeCharProc [obj] = writeCharProc [obj, Port stdout]-writeCharProc [obj@(Char _), Port port] = do- output <- liftIO $ try (liftIO $ (hPutStr port $ show obj))- case output of- Left _ -> throwError $ Default "I/O error writing to port"- Right _ -> return $ Nil ""-writeCharProc other = if length other == 2- then throwError $ TypeMismatch "(character port)" $ List other- else throwError $ NumArgs 2 other--readContents :: [LispVal] -> IOThrowsError LispVal-readContents [String filename] = liftM String $ liftIO $ readFile filename-readContents [] = throwError $ NumArgs 1 []-readContents args@(_ : _) = throwError $ NumArgs 1 args--load :: String -> IOThrowsError [LispVal]-load filename = do- result <- liftIO $ doesFileExist filename- if result- then (liftIO $ readFile filename) >>= liftThrows . readExprList- else throwError $ Default $ "File does not exist: " ++ filename--readAll :: [LispVal] -> IOThrowsError LispVal-readAll [String filename] = liftM List $ load filename-readAll [] = throwError $ NumArgs 1 []-readAll args@(_ : _) = throwError $ NumArgs 1 args+ ("read-all", readAll),+ ("gensym", gensym)] +{- "Pure" primitive functions -} primitives :: [(String, [LispVal] -> ThrowsError LispVal)] primitives = [("+", numAdd), ("-", numSub),@@ -958,320 +982,3 @@ ("string-copy", stringCopy), ("boolean?", isBoolean)]--data Unpacker = forall a . Eq a => AnyUnpacker (LispVal -> ThrowsError a)--unpackEquals :: LispVal -> LispVal -> Unpacker -> ThrowsError Bool-unpackEquals arg1 arg2 (AnyUnpacker unpacker) =- do unpacked1 <- unpacker arg1- unpacked2 <- unpacker arg2- return $ unpacked1 == unpacked2- `catchError` (const $ return False)--boolBinop :: (LispVal -> ThrowsError a) -> (a -> a -> Bool) -> [LispVal] -> ThrowsError LispVal-boolBinop unpacker op args = if length args /= 2- then throwError $ NumArgs 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--{- 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-unpackStr (String s) = return s-unpackStr (Number s) = return $ show s-unpackStr (Bool s) = return $ show s-unpackStr notString = throwError $ TypeMismatch "string" notString--unpackBool :: LispVal -> ThrowsError Bool-unpackBool (Bool b) = return b-unpackBool notBool = throwError $ TypeMismatch "boolean" notBool---- List primitives-car :: [LispVal] -> ThrowsError LispVal-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 (_ : 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--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--equal :: [LispVal] -> ThrowsError LispVal-equal [(Vector arg1), (Vector arg2)] = eqvList equal [List $ (elems arg1), List $ (elems arg2)]-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)- [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---- ------------ Vector Primitives ----------------makeVector, buildVector, vectorLength, vectorRef, vectorToList, listToVector :: [LispVal] -> ThrowsError LispVal-makeVector [(Number n)] = makeVector [Number n, List []]-makeVector [(Number n), a] = do- 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--buildVector (o : os) = do- let lst = o : os- return $ Vector $ (listArray (0, length lst - 1)) lst-buildVector badArgList = throwError $ NumArgs 1 badArgList--vectorLength [(Vector v)] = return $ Number $ toInteger $ length (elems v)-vectorLength [badType] = throwError $ TypeMismatch "vector" badType-vectorLength badArgList = throwError $ NumArgs 1 badArgList--vectorRef [(Vector v), (Number n)] = return $ v ! (fromInteger n)-vectorRef [badType] = throwError $ TypeMismatch "vector integer" badType-vectorRef badArgList = throwError $ NumArgs 2 badArgList--vectorToList [(Vector v)] = return $ List $ elems v-vectorToList [badType] = throwError $ TypeMismatch "vector" badType-vectorToList badArgList = throwError $ NumArgs 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---- ------------ Hash Table Primitives ------------------ Future: support (equal?), (hash) parameters-hashTblMake, isHashTbl, hashTblExists, hashTblRef, hashTblSize, hashTbl2List, hashTblKeys, hashTblValues, hashTblCopy :: [LispVal] -> ThrowsError LispVal-hashTblMake _ = return $ HashTable $ Data.Map.fromList []--isHashTbl [(HashTable _)] = return $ Bool True-isHashTbl _ = return $ Bool False--hashTblExists [(HashTable ht), key@(_)] = do- 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--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-hashTblRef [(HashTable ht), key@(_), Func _ _ _ _] = do- case Data.Map.lookup key ht of- Just val -> return $ val- 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--hashTblSize [(HashTable ht)] = return $ Number $ toInteger $ Data.Map.size ht-hashTblSize [badType] = throwError $ TypeMismatch "hash-table" badType-hashTblSize badArgList = throwError $ NumArgs 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--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--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--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---- ------------ String Primitives ----------------buildString :: [LispVal] -> ThrowsError LispVal-buildString [(Char c)] = return $ String [c]-buildString (Char c : rest) = do- cs <- buildString rest- case cs of- String s -> return $ String $ [c] ++ s- badType -> throwError $ TypeMismatch "character" badType-buildString [badType] = throwError $ TypeMismatch "character" badType-buildString badArgList = throwError $ NumArgs 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--doMakeString :: forall a . (Num a) => a -> Char -> String -> LispVal-doMakeString n char s =- if n == 0- then String s- 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...-stringLength [badType] = throwError $ TypeMismatch "string" badType-stringLength badArgList = throwError $ NumArgs 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--substring :: [LispVal] -> ThrowsError LispVal-substring [(String s), (Number start), (Number end)] =- do let slength = fromInteger $ end - start- 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--stringCIEquals :: [LispVal] -> ThrowsError LispVal-stringCIEquals [(String str1), (String str2)] = do- if (length str1) /= (length str2)- then return $ Bool False- 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)- then ciCmp s1 s2 (idx + 1)- else False-stringCIEquals [badType] = throwError $ TypeMismatch "string string" badType-stringCIEquals badArgList = throwError $ NumArgs 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--stringAppend :: [LispVal] -> ThrowsError LispVal-stringAppend [(String s)] = return $ String s -- Needed for "last" string value-stringAppend (String st : sts) = do- rest <- stringAppend sts- case rest of- String s -> return $ String $ st ++ s- other -> throwError $ TypeMismatch "string" other-stringAppend [badType] = throwError $ TypeMismatch "string" badType-stringAppend badArgList = throwError $ NumArgs 1 badArgList--stringToNumber :: [LispVal] -> ThrowsError LispVal-stringToNumber [(String s)] = do- result <- (readExpr s)- case result of- n@(Number _) -> return n- n@(Rational _) -> return n- n@(Float _) -> return n- n@(Complex _) -> return n- _ -> return $ Bool False-stringToNumber [(String s), Number radix] = do- case radix of- 2 -> stringToNumber [String $ "#b" ++ s]- 8 -> stringToNumber [String $ "#o" ++ s]- 10 -> stringToNumber [String s]- 16 -> stringToNumber [String $ "#x" ++ s]- _ -> throwError $ Default $ "Invalid radix: " ++ show radix-stringToNumber [badType] = throwError $ TypeMismatch "string" badType-stringToNumber badArgList = throwError $ NumArgs 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--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--stringCopy :: [LispVal] -> ThrowsError LispVal-stringCopy [String s] = return $ String s-stringCopy [badType] = throwError $ TypeMismatch "string" badType-stringCopy badArgList = throwError $ NumArgs 2 badArgList--isDottedList :: [LispVal] -> ThrowsError LispVal-isDottedList ([DottedList _ _]) = return $ Bool True--- Must include lists as well since they are made up of 'chains' of pairs-isDottedList ([List []]) = return $ Bool False-isDottedList ([List _]) = return $ Bool True-isDottedList _ = return $ Bool False--isProcedure :: [LispVal] -> ThrowsError LispVal-isProcedure ([Continuation _ _ _ _ _]) = return $ Bool True-isProcedure ([PrimitiveFunc _]) = return $ Bool True-isProcedure ([Func _ _ _ _]) = return $ Bool True-isProcedure ([IOFunc _]) = return $ Bool True-isProcedure ([EvalFunc _]) = return $ Bool True-isProcedure _ = return $ Bool False--isVector, isList :: LispVal -> ThrowsError LispVal-isVector (Vector _) = return $ Bool True-isVector _ = return $ Bool False-isList (List _) = return $ Bool True-isList _ = return $ Bool False--isNull :: [LispVal] -> ThrowsError LispVal-isNull ([List []]) = return $ Bool True-isNull _ = return $ Bool False--isEOFObject :: [LispVal] -> ThrowsError LispVal-isEOFObject ([EOF]) = return $ Bool True-isEOFObject _ = return $ Bool False--isSymbol :: [LispVal] -> ThrowsError LispVal-isSymbol ([Atom _]) = return $ Bool True-isSymbol _ = return $ Bool False--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--string2Symbol :: [LispVal] -> ThrowsError LispVal-string2Symbol ([String s]) = return $ Atom s-string2Symbol [] = throwError $ NumArgs 1 []-string2Symbol [notString] = throwError $ TypeMismatch "string" notString-string2Symbol args@(_ : _) = throwError $ NumArgs 1 args--isChar :: [LispVal] -> ThrowsError LispVal-isChar ([Char _]) = return $ Bool True-isChar _ = return $ Bool False--isString :: [LispVal] -> ThrowsError LispVal-isString ([String _]) = return $ Bool True-isString _ = return $ Bool False--isBoolean :: [LispVal] -> ThrowsError LispVal-isBoolean ([Bool _]) = return $ Bool True-isBoolean _ = return $ Bool False
hs-src/Language/Scheme/Macro.hs view
@@ -41,11 +41,18 @@ import Language.Scheme.Variables import Control.Monad.Error import Data.Array--- import Debug.Trace -- Only req'd to support trace, can be disabled at any time...+import Debug.Trace -- Only req'd to support trace, can be disabled at any time... {- Nice FAQ regarding macro's, points out some of the limitations of current implementation http://community.schemewiki.org/?scheme-faq-macros -} ++{- Consider high-level ideas from these articles (of all places):+ -+ - http://en.wikipedia.org/wiki/Scheme_(programming_language)#Hygienic_macros+ - http://en.wikipedia.org/wiki/Hygienic_macro+ - -}+ {- |macroEval Search for macro's in the AST, and transform any that are found. There is also a special case (define-syntax) that loads new rules. -}@@ -62,11 +69,13 @@ _ <- defineNamespacedVar env macroNamespace keyword syntaxRules return $ Nil "" -- Sentinal value +{- -- Inspect a list of code, and transform as necessary macroEval env (List (x@(List _) : xs)) = do first <- macroEval env x rest <- mapM (macroEval env) xs return $ List $ first : rest+-} {- Inspect code for macros -@@ -77,16 +86,16 @@ begins with the keyword for the macro." - -}-macroEval env lisp@(List (Atom x : xs)) = do- isDefined <- liftIO $ isNamespacedBound env macroNamespace x- if isDefined+macroEval env lisp@(List (Atom x : _)) = do+ isDefined <- liftIO $ isNamespacedRecBound env macroNamespace x+ isDefinedAsVar <- liftIO $ isBound env x -- TODO: Not entirely correct; for example if a macro and var + -- are defined in same env with same name, which one should be selected?+ if isDefined && not isDefinedAsVar --(trace (show "mEval [" ++ show lisp ++ ", " ++ show x ++ "]: " ++ show isDefined) isDefined) then do (List (Atom "syntax-rules" : (List identifiers : rules))) <- getNamespacedVar env macroNamespace x -- Transform the input and then call macroEval again, since a macro may be contained within... macroEval env =<< macroTransform env (List identifiers) rules lisp- else do- rest <- mapM (macroEval env) xs- return $ List $ (Atom x) : rest+ else return lisp -- No macro to process, just return code as it is... macroEval _ lisp@(_) = return lisp@@ -126,7 +135,7 @@ {- Given input, determine if that input matches any rules @return Transformed code, or Nil if no rules match -} matchRule :: Env -> LispVal -> Env -> LispVal -> LispVal -> IOThrowsError LispVal-matchRule _ identifiers localEnv (List [pattern, template]) (List inputVar) = do+matchRule outerEnv identifiers localEnv (List [pattern, template]) (List inputVar) = do let is = tail inputVar let p = case pattern of DottedList ds d -> case ds of@@ -135,31 +144,53 @@ _ -> pattern case p of List (Atom _ : ps) -> do- match <- loadLocal localEnv identifiers (List ps) (List is) False False+ match <- loadLocal outerEnv localEnv identifiers (List ps) (List is) False False case match of Bool False -> return $ Nil ""- _ -> transformRule localEnv 0 (List []) template (List [])+ _ -> do+-- bindings <- findBindings localEnv pattern+-- transformRule outerEnv (trace ("bindings = " ++ show bindings) localEnv) 0 (List []) template (List [])+ transformRule outerEnv localEnv 0 (List []) template (List []) _ -> throwError $ BadSpecialForm "Malformed rule in syntax-rules" p matchRule _ _ _ rule input = do throwError $ BadSpecialForm "Malformed rule in syntax-rules" $ List [Atom "rule: ", rule, Atom "input: ", input] +-- Issue #30+{-------------------------+-- Just some test code, this needs to be more sophisticated than simply finding a list of them.+-- because we probably need to know the context - IE, (begin ... (lambda ...) (define ...) x) - x should+-- not be rewritten if it is the name of one of the lambda arguments+findBindings :: Env -> LispVal -> IOThrowsError LispVal+findBindings localEnv pattern@(List (_ : ps)) = searchForBindings localEnv (List ps) [] ++searchForBindings :: Env -> LispVal -> [LispVal] -> IOThrowsError LispVal+--env pattern@(List (List (Atom "lambda" : List bs : _) : ps)) bindings = searchForBindings env (List ps) (bindings ++ bs) +--searchForBindings env pattern@(List (List (Atom "lambda" : List bs : _) : ps)) bindings = searchForBindings env (List ps) (bindings ++ bs) +searchForBindings env pattern@(List (p : ps)) bindings = do+ newBindings <- searchForBindings env (List [p]) []+ case newBindings of+ List n -> searchForBindings env (List ps) (bindings ++ n)+ _ -> throwError $ Default "Unexpected error in searchForBindings" +searchForBindings _ _ bindings = return $ List bindings+-------------------------}+ {- loadLocal - Determine if pattern matches input, loading input into pattern variables as we go, in preparation for macro transformation. -}-loadLocal :: Env -> LispVal -> LispVal -> LispVal -> Bool -> Bool -> IOThrowsError LispVal-loadLocal localEnv identifiers pattern input hasEllipsis outerHasEllipsis = do+loadLocal :: Env -> Env -> LispVal -> LispVal -> LispVal -> Bool -> Bool -> IOThrowsError LispVal+loadLocal outerEnv localEnv identifiers pattern input hasEllipsis outerHasEllipsis = do case (pattern, input) of {- For vectors, just use list match for now, since vector input matching just requires a subset of that behavior. Should be OK since parser would catch problems with trying to add pair syntax to a vector declaration. -} ((Vector p), (Vector i)) -> do- loadLocal localEnv identifiers (List $ elems p) (List $ elems i) False outerHasEllipsis+ loadLocal outerEnv localEnv identifiers (List $ elems p) (List $ elems i) False outerHasEllipsis ((DottedList ps p), (DottedList is i)) -> do- result <- loadLocal localEnv identifiers (List ps) (List is) False outerHasEllipsis+ result <- loadLocal outerEnv localEnv identifiers (List ps) (List is) False outerHasEllipsis case result of- Bool True -> loadLocal localEnv identifiers p i False outerHasEllipsis+ Bool True -> loadLocal outerEnv localEnv identifiers p i False outerHasEllipsis _ -> return $ Bool False (List (p : ps), List (i : is)) -> do -- check first input against first pattern, recurse...@@ -169,19 +200,19 @@ {- FUTURE: error if ... detected when there is an outer ... ???? no, this should (eventually) be allowed. See scheme-faq-macros -} - status <- checkLocal localEnv identifiers (localHasEllipsis || outerHasEllipsis) p i+ status <- checkLocal outerEnv localEnv identifiers (localHasEllipsis || outerHasEllipsis) p i case status of -- No match Bool False -> if localHasEllipsis {- No match, must be finished with ... Move past it, but keep the same input. -} then do- loadLocal localEnv identifiers (List $ tail ps) (List (i : is)) False outerHasEllipsis+ loadLocal outerEnv localEnv identifiers (List $ tail ps) (List (i : is)) False outerHasEllipsis else return $ Bool False -- There was a match _ -> if localHasEllipsis- then loadLocal localEnv identifiers pattern (List is) True outerHasEllipsis- else loadLocal localEnv identifiers (List ps) (List is) False outerHasEllipsis+ then loadLocal outerEnv localEnv identifiers pattern (List is) True outerHasEllipsis+ else loadLocal outerEnv localEnv identifiers (List ps) (List is) False outerHasEllipsis -- Base case - All data processed (List [], List []) -> return $ Bool True@@ -199,7 +230,7 @@ (List [], _) -> return $ Bool False -- Check input against pattern (both should be single var)- (_, _) -> checkLocal localEnv identifiers (hasEllipsis || outerHasEllipsis) pattern input+ (_, _) -> checkLocal outerEnv localEnv identifiers (hasEllipsis || outerHasEllipsis) pattern input {- Check pattern against input to determine if there is a match -@@ -209,19 +240,20 @@ - @param pattern - Pattern to match - @param input - Input to be matched -}-checkLocal :: Env -> LispVal -> Bool -> LispVal -> LispVal -> IOThrowsError LispVal-checkLocal _ _ _ (Bool pattern) (Bool input) = return $ Bool $ pattern == input-checkLocal _ _ _ (Number pattern) (Number input) = return $ Bool $ pattern == input-checkLocal _ _ _ (Float pattern) (Float input) = return $ Bool $ pattern == input-checkLocal _ _ _ (String pattern) (String input) = return $ Bool $ pattern == input-checkLocal _ _ _ (Char pattern) (Char input) = return $ Bool $ pattern == input-checkLocal localEnv identifiers hasEllipsis (Atom pattern) input = do+checkLocal :: Env -> Env -> LispVal -> Bool -> LispVal -> LispVal -> IOThrowsError LispVal+checkLocal _ _ _ _ (Bool pattern) (Bool input) = return $ Bool $ pattern == input+checkLocal _ _ _ _ (Number pattern) (Number input) = return $ Bool $ pattern == input+checkLocal _ _ _ _ (Float pattern) (Float input) = return $ Bool $ pattern == input+checkLocal _ _ _ _ (String pattern) (String input) = return $ Bool $ pattern == input+checkLocal _ _ _ _ (Char pattern) (Char input) = return $ Bool $ pattern == input+checkLocal outerEnv localEnv identifiers hasEllipsis (Atom pattern) input = do if hasEllipsis {- FUTURE: may be able to simplify both cases below by using a lambda function to store the 'save' actions -} -- Var is part of a 0-to-many match, store up in a list... then do isDefined <- liftIO $ isBound localEnv pattern+ isLexicallyDefinedVar <- liftIO $ isBound outerEnv pattern -- -- If pattern is a literal identifier, need to ensure -- input matches that literal, or that (in this case)@@ -232,11 +264,20 @@ Bool True -> do case input of Atom inpt -> do- if (pattern == inpt)- then do- -- Set variable in the local environment- _ <- addPatternVar isDefined $ Atom pattern- return $ Bool True+ if (pattern == inpt) + then if isLexicallyDefinedVar == False + -- Var is not bound in outer code; proceed+ then do+ -- Set variable in the local environment+ _ <- addPatternVar isDefined $ Atom pattern+ return $ Bool True+ -- Var already bound in enclosing environment prior to evaluating macro.+ -- So... do not match it here.+ --+ -- See section 4.3.2 of R5RS, in particular:+ -- " If a literal identifier is inserted as a bound identifier then it is + -- in effect renamed to prevent inadvertent captures of free identifiers "+ else return $ Bool False else return $ Bool False -- Pattern/Input cannot match because input is not an atom _ -> return $ Bool False@@ -248,13 +289,14 @@ -- else do isIdent <- findAtom (Atom pattern) identifiers- case isIdent of+ isLexicallyDefinedPatternVar <- liftIO $ isBound outerEnv pattern -- Var defined in scope outside macro+ case (isIdent) of -- Fail the match if pattern is a literal identifier and input does not match Bool True -> do case input of Atom inpt -> do -- Pattern/Input are atoms; both must match- if (pattern == inpt)+ if (pattern == inpt && (not isLexicallyDefinedPatternVar)) -- Regarding lex binding; see above, sec 4.3.2 from spec then do _ <- defineVar localEnv pattern input return $ Bool True else return $ (Bool False)@@ -264,6 +306,24 @@ -- No literal identifier, just load up the var _ -> do _ <- defineVar localEnv pattern input return $ Bool True+{- TODO:+ the issue with this is that sometimes the var needs to be preserved and not have its value directly inserted.+ the real fix is to rename any identifiers bound in the macro transform. for example, (let ((temp ...)) ...) should+ have the variable renamed to temp-1 (for example)+++ _ -> case input of+ Atom inpt -> do+ isLexicallyDefinedInput <- liftIO $ isBound outerEnv inpt -- Var defined in scope outside macro+ if isLexicallyDefinedInput+ then do _ <- defineVar localEnv pattern (trace ("sec 4.3.2 for: " ++ inpt) (Nil inpt)) -- Var defined outside macro, flag as such for transform code+-- TODO: flag as such from the above ellipsis code as well + return $ Bool True+ else do _ <- defineVar localEnv pattern input+ return $ Bool True+ _ -> do _ <- defineVar localEnv pattern input+ return $ Bool True+-} where addPatternVar isDefined val = do if isDefined@@ -273,28 +333,28 @@ _ -> throwError $ Default "Unexpected error in checkLocal (Atom)" else defineVar localEnv pattern (List [val]) -checkLocal localEnv identifiers hasEllipsis pattern@(Vector _) input@(Vector _) =- loadLocal localEnv identifiers pattern input False hasEllipsis+checkLocal outerEnv localEnv identifiers hasEllipsis pattern@(Vector _) input@(Vector _) =+ loadLocal outerEnv localEnv identifiers pattern input False hasEllipsis -checkLocal localEnv identifiers hasEllipsis pattern@(DottedList _ _) input@(DottedList _ _) =- loadLocal localEnv identifiers pattern input False hasEllipsis+checkLocal outerEnv localEnv identifiers hasEllipsis pattern@(DottedList _ _) input@(DottedList _ _) =+ loadLocal outerEnv localEnv identifiers pattern input False hasEllipsis -- throwError $ BadSpecialForm "Test" input-checkLocal localEnv identifiers hasEllipsis pattern@(DottedList ps p) input@(List (i : is)) = do+checkLocal outerEnv localEnv identifiers hasEllipsis pattern@(DottedList ps p) input@(List (i : is)) = do if (length ps) == (length is) {- Lists are same length, implying elements in both should be the same. Cast pair to a List for further processing -}- then loadLocal localEnv identifiers (List $ ps ++ [p]) input False hasEllipsis+ then loadLocal outerEnv localEnv identifiers (List $ ps ++ [p]) input False hasEllipsis {- Idea here is that if we have a dotted list, the last component does not have to be provided in the input. So in that case just fill in an empty list for the missing component. -}- else loadLocal localEnv identifiers pattern (DottedList (i : is) (List [])) False hasEllipsis-checkLocal localEnv identifiers hasEllipsis pattern@(List _) input@(List _) =- loadLocal localEnv identifiers pattern input False hasEllipsis+ else loadLocal outerEnv localEnv identifiers pattern (DottedList (i : is) (List [])) False hasEllipsis+checkLocal outerEnv localEnv identifiers hasEllipsis pattern@(List _) input@(List _) =+ loadLocal outerEnv localEnv identifiers pattern input False hasEllipsis -checkLocal _ _ _ _ _ = return $ Bool False+checkLocal _ _ _ _ _ _ = return $ Bool False {- Transform input by walking the tranform structure and creating a new structure with the same form, replacing identifiers in the tranform with those bound in localEnv -}-transformRule :: Env -> Int -> LispVal -> LispVal -> LispVal -> IOThrowsError LispVal+transformRule :: Env -> Env -> Int -> LispVal -> LispVal -> LispVal -> IOThrowsError LispVal {- - Recursively transform a list@@ -309,132 +369,155 @@ - ellipsisList - Temporarily holds value of the "outer" result while we process the - zero-or-more match. Once that is complete we swap this value back into it's rightful place -}-transformRule localEnv ellipsisIndex (List result) transform@(List (List l : ts)) (List ellipsisList) = do+transformRule outerEnv localEnv ellipsisIndex (List result) transform@(List (List l : ts)) (List ellipsisList) = do if macroElementMatchesMany transform then do- curT <- transformRule localEnv (ellipsisIndex + 1) (List []) (List l) (List result)+ curT <- transformRule outerEnv localEnv (ellipsisIndex + 1) (List []) (List l) (List result) case curT of Nil _ -> if ellipsisIndex == 0 -- First time through and no match ("zero" case). Use tail to move past the "..."- then transformRule localEnv 0 (List $ result) (List $ tail ts) (List [])+ then transformRule outerEnv localEnv 0 (List $ result) (List $ tail ts) (List []) -- Done with zero-or-more match, append intermediate results (ellipsisList) and move past the "..."- else transformRule localEnv 0 (List $ ellipsisList ++ result) (List $ tail ts) (List [])+ else transformRule outerEnv localEnv 0 (List $ ellipsisList ++ result) (List $ tail ts) (List []) -- Dotted list transform returned during processing... List [Nil _, List _] -> if ellipsisIndex == 0 -- First time through and no match ("zero" case). Use tail to move past the "..."- then transformRule localEnv 0 (List $ result) (List $ tail ts) (List [])+ then transformRule outerEnv localEnv 0 (List $ result) (List $ tail ts) (List []) -- Done with zero-or-more match, append intermediate results (ellipsisList) and move past the "..."- else transformRule localEnv 0 (List $ result) (List $ tail ts) (List [])- List _ -> transformRule localEnv (ellipsisIndex + 1) (List $ result ++ [curT]) transform (List ellipsisList)+ else transformRule outerEnv localEnv 0 (List $ result) (List $ tail ts) (List [])+ List _ -> transformRule outerEnv localEnv (ellipsisIndex + 1) (List $ result ++ [curT]) transform (List ellipsisList) _ -> throwError $ Default "Unexpected error" else do- lst <- transformRule localEnv ellipsisIndex (List []) (List l) (List ellipsisList)+ lst <- transformRule outerEnv localEnv ellipsisIndex (List []) (List l) (List ellipsisList) case lst of List [Nil _, _] -> return lst- List _ -> transformRule localEnv ellipsisIndex (List $ result ++ [lst]) (List ts) (List ellipsisList)+ List _ -> transformRule outerEnv localEnv ellipsisIndex (List $ result ++ [lst]) (List ts) (List ellipsisList) Nil _ -> return lst _ -> throwError $ BadSpecialForm "Macro transform error" $ List [lst, (List l), Number $ toInteger ellipsisIndex] -transformRule localEnv ellipsisIndex (List result) transform@(List ((Vector v) : ts)) (List ellipsisList) = do+transformRule outerEnv localEnv ellipsisIndex (List result) transform@(List ((Vector v) : ts)) (List ellipsisList) = do if macroElementMatchesMany transform then do -- Idea here is that we need to handle case where you have (vector ...) - EG: (#(var step) ...)- curT <- transformRule localEnv (ellipsisIndex + 1) (List []) (List $ elems v) (List result)+ curT <- transformRule outerEnv localEnv (ellipsisIndex + 1) (List []) (List $ elems v) (List result) case curT of Nil _ -> if ellipsisIndex == 0 -- First time through and no match ("zero" case). Use tail to move past the "..."- then transformRule localEnv 0 (List $ result) (List $ tail ts) (List [])+ then transformRule outerEnv localEnv 0 (List $ result) (List $ tail ts) (List []) -- Done with zero-or-more match, append intermediate results (ellipsisList) and move past the "..."- else transformRule localEnv 0 (List $ ellipsisList ++ result) (List $ tail ts) (List [])- List t -> transformRule localEnv (ellipsisIndex + 1) (List $ result ++ [asVector t]) transform (List ellipsisList)+ else transformRule outerEnv localEnv 0 (List $ ellipsisList ++ result) (List $ tail ts) (List [])+ List t -> transformRule outerEnv localEnv (ellipsisIndex + 1) (List $ result ++ [asVector t]) transform (List ellipsisList) _ -> throwError $ Default "Unexpected error in transformRule"- else do lst <- transformRule localEnv ellipsisIndex (List []) (List $ elems v) (List ellipsisList)+ else do lst <- transformRule outerEnv localEnv ellipsisIndex (List []) (List $ elems v) (List ellipsisList) case lst of List l -> do- transformRule localEnv ellipsisIndex (List $ result ++ [asVector l]) (List ts) (List ellipsisList)+ transformRule outerEnv localEnv ellipsisIndex (List $ result ++ [asVector l]) (List ts) (List ellipsisList) Nil _ -> return lst _ -> throwError $ BadSpecialForm "transformRule: Macro transform error" $ List [(List ellipsisList), lst, (List [Vector v]), Number $ toInteger ellipsisIndex] where asVector lst = (Vector $ (listArray (0, length lst - 1)) lst) -transformRule localEnv ellipsisIndex (List result) transform@(List (dl@(DottedList _ _) : ts)) (List ellipsisList) = do+transformRule outerEnv localEnv ellipsisIndex (List result) transform@(List (dl@(DottedList _ _) : ts)) (List ellipsisList) = do if macroElementMatchesMany transform then do -- Idea here is that we need to handle case where you have (pair ...) - EG: ((var . step) ...)- curT <- transformDottedList localEnv (ellipsisIndex + 1) (List []) (List [dl]) (List result)+ curT <- transformDottedList outerEnv localEnv (ellipsisIndex + 1) (List []) (List [dl]) (List result) case curT of Nil _ -> if ellipsisIndex == 0 -- First time through and no match ("zero" case). Use tail to move past the "..."- then transformRule localEnv 0 (List $ result) (List $ tail ts) (List [])+ then transformRule outerEnv localEnv 0 (List $ result) (List $ tail ts) (List []) -- Done with zero-or-more match, append intermediate results (ellipsisList) and move past the "..."- else transformRule localEnv 0 (List $ ellipsisList ++ result) (List $ tail ts) (List [])+ else transformRule outerEnv localEnv 0 (List $ ellipsisList ++ result) (List $ tail ts) (List []) {- This case is here because we need to process individual components of the pair to determine whether we are done with the match. It is similar to above but not exact... -} List [Nil _, List _] -> if ellipsisIndex == 0 -- First time through and no match ("zero" case). Use tail to move past the "..."- then transformRule localEnv 0 (List $ result) (List $ tail ts) (List [])+ then transformRule outerEnv localEnv 0 (List $ result) (List $ tail ts) (List []) -- Done with zero-or-more match, append intermediate results (ellipsisList) and move past the "..."- else transformRule localEnv 0 (List $ result) (List $ tail ts) (List [])- List t -> transformRule localEnv (ellipsisIndex + 1) (List $ result ++ t) transform (List ellipsisList)+ else transformRule outerEnv localEnv 0 (List $ result) (List $ tail ts) (List [])+ List t -> transformRule outerEnv localEnv (ellipsisIndex + 1) (List $ result ++ t) transform (List ellipsisList) _ -> throwError $ Default "Unexpected error in transformRule"- else do lst <- transformDottedList localEnv ellipsisIndex (List []) (List [dl]) (List ellipsisList)+ else do lst <- transformDottedList outerEnv localEnv ellipsisIndex (List []) (List [dl]) (List ellipsisList) case lst of List [Nil _, List _] -> return lst- List l -> transformRule localEnv ellipsisIndex (List $ result ++ l) (List ts) (List ellipsisList)+ List l -> transformRule outerEnv localEnv ellipsisIndex (List $ result ++ l) (List ts) (List ellipsisList) Nil _ -> return lst _ -> throwError $ BadSpecialForm "transformRule: Macro transform error" $ List [(List ellipsisList), lst, (List [dl]), Number $ toInteger ellipsisIndex] -- Transform an atom by attempting to look it up as a var...-transformRule localEnv ellipsisIndex (List result) transform@(List (Atom a : ts)) unused = do+transformRule outerEnv localEnv ellipsisIndex (List result) transform@(List (Atom a : ts)) unused = do let hasEllipsis = macroElementMatchesMany transform isDefined <- liftIO $ isBound localEnv a- if hasEllipsis+-- if (trace ("isDefined [" ++ show a ++ "]: " ++ show isDefined) hasEllipsis)+ if (hasEllipsis) then if isDefined- then do- -- get var- var <- getVar localEnv a- -- ensure it is a list- case var of- -- add all elements of the list into result- List v -> transformRule localEnv ellipsisIndex (List $ result ++ v) (List $ tail ts) unused- v@(_) -> transformRule localEnv ellipsisIndex (List $ result ++ [v]) (List $ tail ts) unused+ then do + -- get var+ var <- getVar localEnv a+ -- ensure it is a list+ case var of+ -- add all elements of the list into result+ List v -> transformRule outerEnv localEnv ellipsisIndex (List $ result ++ v) (List $ tail ts) unused+{- TODO: Nil input -> do -- Var lexically defined outside of macro, load from there+--+-- TODO: this could be a problem, because we need to signal the end of the ... and do not want an infinite loop.+-- but we want the lexical value as well. need to think about this in more detail to get a truly workable solution+--+ v <- getVar outerEnv input+ transformRule outerEnv localEnv ellipsisIndex (List $ result ++ [v]) (List $ tail ts) unused -}+ v@(_) -> transformRule outerEnv localEnv ellipsisIndex (List $ result ++ [v]) (List $ tail ts) unused else -- Matched 0 times, skip it- transformRule localEnv ellipsisIndex (List result) (List $ tail ts) unused+ transformRule outerEnv localEnv ellipsisIndex (List result) (List $ tail ts) unused else do t <- if isDefined- then do var <- getVar localEnv a- if ellipsisIndex > 0- then do case var of- List v -> if (length v) > (ellipsisIndex - 1)- then return $ v !! (ellipsisIndex - 1)- else return $ Nil ""- _ -> throwError $ Default "Unexpected error in transformRule"- else return var+ then do+ var <- getVar localEnv a+-- if ellipsisIndex > 0--(trace ("var = " ++ show a ++ " lex = " ++ isLexicallyDefinedVar) ellipsisIndex) > 0+-- case (trace ("var = " ++ show var) var) of+ case (var) of+ Nil input -> do+ v <- getVar outerEnv input+ return v+ _ -> if ellipsisIndex > 0--(trace ("var = " ++ show a) ellipsisIndex) > 0+ then do case var of+ List v -> if (length v) > (ellipsisIndex - 1)+ then return $ v !! (ellipsisIndex - 1)+ else return $ Nil ""+ _ -> throwError $ Default "Unexpected error in transformRule"+ else return var else return $ Atom a+-- case (trace ("t = " ++ show t) t) of case t of Nil _ -> return t- _ -> transformRule localEnv ellipsisIndex (List $ result ++ [t]) (List ts) unused+ _ -> transformRule outerEnv localEnv ellipsisIndex (List $ result ++ [t]) (List ts) unused -- Transform anything else as itself...-transformRule localEnv ellipsisIndex (List result) (List (t : ts)) (List ellipsisList) = do- transformRule localEnv ellipsisIndex (List $ result ++ [t]) (List ts) (List ellipsisList)+transformRule outerEnv localEnv ellipsisIndex (List result) (List (t : ts)) (List ellipsisList) = do+ transformRule outerEnv localEnv ellipsisIndex (List $ result ++ [t]) (List ts) (List ellipsisList) -- Base case - empty transform-transformRule _ _ result@(List _) (List []) _ = do+transformRule _ _ _ result@(List _) (List []) _ = do return result -transformRule _ ellipsisIndex result transform unused = do- throwError $ BadSpecialForm "An error occurred during macro transform" $ List [(Number $ toInteger ellipsisIndex), result, transform, unused]+-- Transform is a single var, just look it up.+transformRule _ localEnv _ _ (Atom transform) _ = do+ v <- getVar localEnv transform+ return v -transformDottedList :: Env -> Int -> LispVal -> LispVal -> LispVal -> IOThrowsError LispVal-transformDottedList localEnv ellipsisIndex (List result) (List (DottedList ds d : ts)) (List ellipsisList) = do- lsto <- transformRule localEnv ellipsisIndex (List []) (List ds) (List ellipsisList)+-- If transforming into a scalar, just return the transform directly...+-- Not sure if this is strictly desirable, but does not break any tests so we'll go with it for now.+transformRule _ _ _ _ transform _ = do -- OLD CODE: result transform unused = do+ return transform -- OLD CODE: throwError $ BadSpecialForm "An error occurred during macro transform" $ List [(Number $ toInteger ellipsisIndex), result, transform, unused]++transformDottedList :: Env -> Env -> Int -> LispVal -> LispVal -> LispVal -> IOThrowsError LispVal+transformDottedList outerEnv localEnv ellipsisIndex (List result) (List (DottedList ds d : ts)) (List ellipsisList) = do+ lsto <- transformRule outerEnv localEnv ellipsisIndex (List []) (List ds) (List ellipsisList) case lsto of List lst -> do- r <- transformRule localEnv ellipsisIndex (List []) (List [d]) (List ellipsisList)+ r <- transformRule outerEnv localEnv ellipsisIndex (List []) (List [d]) (List ellipsisList) case r of -- Trailing symbol in the pattern may be neglected in the transform, so skip it...- List [List []] -> transformRule localEnv ellipsisIndex (List $ result ++ [List lst]) (List ts) (List ellipsisList)+ List [List []] -> transformRule outerEnv localEnv ellipsisIndex (List $ result ++ [List lst]) (List ts) (List ellipsisList) -- -- FUTURE: Issue #9 - the transform needs to be as follows: --@@ -450,13 +533,13 @@ List [rst] -> do src <- lookupPatternVarSrc localEnv $ List ds case src of- String "pair" -> transformRule localEnv ellipsisIndex (List $ result ++ [DottedList lst rst]) (List ts) (List ellipsisList)- _ -> transformRule localEnv ellipsisIndex (List $ result ++ [List $ lst ++ [rst]]) (List ts) (List ellipsisList)+ String "pair" -> transformRule outerEnv localEnv ellipsisIndex (List $ result ++ [DottedList lst rst]) (List ts) (List ellipsisList)+ _ -> transformRule outerEnv localEnv ellipsisIndex (List $ result ++ [List $ lst ++ [rst]]) (List ts) (List ellipsisList) _ -> throwError $ BadSpecialForm "Macro transform error processing pair" $ DottedList ds d Nil _ -> return $ List [Nil "", List ellipsisList] _ -> throwError $ BadSpecialForm "Macro transform error processing pair" $ DottedList ds d -transformDottedList _ _ _ _ _ = throwError $ Default "Unexpected error in transformDottedList"+transformDottedList _ _ _ _ _ _ = throwError $ Default "Unexpected error in transformDottedList" -- Find an atom in a list; non-recursive (IE, a sub-list will not be inspected) findAtom :: LispVal -> LispVal -> IOThrowsError LispVal
+ hs-src/Language/Scheme/Primitives.hs view
@@ -0,0 +1,459 @@+{- |+Module : Language.Scheme.Primitives+Copyright : Justin Ethier+Licence : MIT (see LICENSE in the distribution)++Maintainer : github.com/justinethier+Stability : experimental+Portability : portable++husk scheme interpreter++A lightweight dialect of R5RS scheme.++This module contains Primitive functions written in Haskell.+-}++module Language.Scheme.Primitives where+import Language.Scheme.Numerical+import Language.Scheme.Parser+import Language.Scheme.Types+import Control.Monad.Error+import Char+import Data.Array+import Data.Unique+import qualified Data.Map+import IO hiding (try)+import System.Directory (doesFileExist)+import System.IO.Error++---------------------------------------------------+-- I/O Primitives+-- These primitives all execute within the IO monad+---------------------------------------------------+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++closePort :: [LispVal] -> IOThrowsError LispVal+closePort [Port port] = liftIO $ hClose port >> (return $ Bool True)+closePort _ = return $ Bool False++currentInputPort, currentOutputPort :: [LispVal] -> IOThrowsError LispVal+{- FUTURE: For now, these are just hardcoded to the standard i/o ports.+a future implementation that includes with-*put-from-file+would require a more involved implementation here as well as+other I/O functions hooking into these instead of std* -}+currentInputPort _ = return $ Port stdin+currentOutputPort _ = return $ Port stdout++isInputPort, isOutputPort :: [LispVal] -> IOThrowsError LispVal+isInputPort [Port port] = liftM Bool $ liftIO $ hIsReadable port+isInputPort _ = return $ Bool False++isOutputPort [Port port] = liftM Bool $ liftIO $ hIsWritable port+isOutputPort _ = return $ Bool False++readProc :: [LispVal] -> IOThrowsError LispVal+readProc [] = readProc [Port stdin]+readProc [Port port] = do+ input <- liftIO $ try (liftIO $ hGetLine port)+ case input of+ Left e -> if isEOFError e+ then return $ EOF+ else throwError $ Default "I/O error reading from port" -- FUTURE: ioError e+ Right inpStr -> do+ liftThrows $ readExpr inpStr+readProc args@(_ : _) = throwError $ BadSpecialForm "" $ List args++readCharProc :: (Handle -> IO Char) -> [LispVal] -> IOThrowsError LispVal+readCharProc func [] = readCharProc func [Port stdin]+readCharProc func [Port port] = do+ liftIO $ hSetBuffering port NoBuffering+ input <- liftIO $ try (liftIO $ func port)+ liftIO $ hSetBuffering port LineBuffering+ case input of+ Left e -> if isEOFError e+ then return $ EOF+ else throwError $ Default "I/O error reading from port"+ Right inpChr -> do+ return $ Char inpChr+readCharProc _ args@(_ : _) = throwError $ BadSpecialForm "" $ List args++{- writeProc :: --forall a (m :: * -> *).+ (MonadIO m, MonadError LispError m) =>+ (Handle -> LispVal -> IO a) -> [LispVal] -> m LispVal -}+writeProc func [obj] = writeProc func [obj, Port stdout]+writeProc func [obj, Port port] = do+ output <- liftIO $ try (liftIO $ func port obj)+ case output of+ Left _ -> throwError $ Default "I/O error writing to port"+ Right _ -> return $ Nil ""+writeProc _ other = if length other == 2+ then throwError $ TypeMismatch "(value port)" $ List other+ else throwError $ NumArgs 2 other++writeCharProc :: [LispVal] -> IOThrowsError LispVal+writeCharProc [obj] = writeCharProc [obj, Port stdout]+writeCharProc [obj@(Char _), Port port] = do+ output <- liftIO $ try (liftIO $ (hPutStr port $ show obj))+ case output of+ Left _ -> throwError $ Default "I/O error writing to port"+ Right _ -> return $ Nil ""+writeCharProc other = if length other == 2+ then throwError $ TypeMismatch "(character port)" $ List other+ else throwError $ NumArgs 2 other++readContents :: [LispVal] -> IOThrowsError LispVal+readContents [String filename] = liftM String $ liftIO $ readFile filename+readContents [] = throwError $ NumArgs 1 []+readContents args@(_ : _) = throwError $ NumArgs 1 args++load :: String -> IOThrowsError [LispVal]+load filename = do+ result <- liftIO $ doesFileExist filename+ if result+ then (liftIO $ readFile filename) >>= liftThrows . readExprList+ else throwError $ Default $ "File does not exist: " ++ filename++readAll :: [LispVal] -> IOThrowsError LispVal+readAll [String filename] = liftM List $ load filename+readAll [] = throwError $ NumArgs 1 []+readAll args@(_ : _) = throwError $ NumArgs 1 args++-- Version of gensym that can be conveniently called from Haskell+_gensym :: String -> IOThrowsError LispVal+_gensym prefix = do+ u <- liftIO $ newUnique+ return $ Atom $ prefix ++ (show $ Number $ toInteger $ hashUnique u)++-- Non-standard function, generate a (reasonably) unique symbol given an optional prefix+gensym :: [LispVal] -> IOThrowsError LispVal+gensym [String prefix] = _gensym prefix+gensym [] = _gensym " g"+gensym args@(_ : _) = throwError $ NumArgs 1 args+++---------------------------------------------------+-- "Pure" primitives+---------------------------------------------------++-- List primitives+car :: [LispVal] -> ThrowsError LispVal+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 (_ : 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++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++equal :: [LispVal] -> ThrowsError LispVal+equal [(Vector arg1), (Vector arg2)] = eqvList equal [List $ (elems arg1), List $ (elems arg2)]+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)+ [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++-- ------------ Vector Primitives --------------++makeVector, buildVector, vectorLength, vectorRef, vectorToList, listToVector :: [LispVal] -> ThrowsError LispVal+makeVector [(Number n)] = makeVector [Number n, List []]+makeVector [(Number n), a] = do+ 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++buildVector (o : os) = do+ let lst = o : os+ return $ Vector $ (listArray (0, length lst - 1)) lst+buildVector badArgList = throwError $ NumArgs 1 badArgList++vectorLength [(Vector v)] = return $ Number $ toInteger $ length (elems v)+vectorLength [badType] = throwError $ TypeMismatch "vector" badType+vectorLength badArgList = throwError $ NumArgs 1 badArgList++vectorRef [(Vector v), (Number n)] = return $ v ! (fromInteger n)+vectorRef [badType] = throwError $ TypeMismatch "vector integer" badType+vectorRef badArgList = throwError $ NumArgs 2 badArgList++vectorToList [(Vector v)] = return $ List $ elems v+vectorToList [badType] = throwError $ TypeMismatch "vector" badType+vectorToList badArgList = throwError $ NumArgs 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++-- ------------ Hash Table Primitives --------------++-- Future: support (equal?), (hash) parameters+hashTblMake, isHashTbl, hashTblExists, hashTblRef, hashTblSize, hashTbl2List, hashTblKeys, hashTblValues, hashTblCopy :: [LispVal] -> ThrowsError LispVal+hashTblMake _ = return $ HashTable $ Data.Map.fromList []++isHashTbl [(HashTable _)] = return $ Bool True+isHashTbl _ = return $ Bool False++hashTblExists [(HashTable ht), key@(_)] = do+ 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++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+hashTblRef [(HashTable ht), key@(_), Func _ _ _ _] = do+ case Data.Map.lookup key ht of+ Just val -> return $ val+ 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++hashTblSize [(HashTable ht)] = return $ Number $ toInteger $ Data.Map.size ht+hashTblSize [badType] = throwError $ TypeMismatch "hash-table" badType+hashTblSize badArgList = throwError $ NumArgs 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++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++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++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++-- ------------ String Primitives --------------++buildString :: [LispVal] -> ThrowsError LispVal+buildString [(Char c)] = return $ String [c]+buildString (Char c : rest) = do+ cs <- buildString rest+ case cs of+ String s -> return $ String $ [c] ++ s+ badType -> throwError $ TypeMismatch "character" badType+buildString [badType] = throwError $ TypeMismatch "character" badType+buildString badArgList = throwError $ NumArgs 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++doMakeString :: forall a . (Num a) => a -> Char -> String -> LispVal+doMakeString n char s =+ if n == 0+ then String s+ 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...+stringLength [badType] = throwError $ TypeMismatch "string" badType+stringLength badArgList = throwError $ NumArgs 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++substring :: [LispVal] -> ThrowsError LispVal+substring [(String s), (Number start), (Number end)] =+ do let slength = fromInteger $ end - start+ 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++stringCIEquals :: [LispVal] -> ThrowsError LispVal+stringCIEquals [(String str1), (String str2)] = do+ if (length str1) /= (length str2)+ then return $ Bool False+ 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)+ then ciCmp s1 s2 (idx + 1)+ else False+stringCIEquals [badType] = throwError $ TypeMismatch "string string" badType+stringCIEquals badArgList = throwError $ NumArgs 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++stringAppend :: [LispVal] -> ThrowsError LispVal+stringAppend [(String s)] = return $ String s -- Needed for "last" string value+stringAppend (String st : sts) = do+ rest <- stringAppend sts+ case rest of+ String s -> return $ String $ st ++ s+ other -> throwError $ TypeMismatch "string" other+stringAppend [badType] = throwError $ TypeMismatch "string" badType+stringAppend badArgList = throwError $ NumArgs 1 badArgList++stringToNumber :: [LispVal] -> ThrowsError LispVal+stringToNumber [(String s)] = do+ result <- (readExpr s)+ case result of+ n@(Number _) -> return n+ n@(Rational _) -> return n+ n@(Float _) -> return n+ n@(Complex _) -> return n+ _ -> return $ Bool False+stringToNumber [(String s), Number radix] = do+ case radix of+ 2 -> stringToNumber [String $ "#b" ++ s]+ 8 -> stringToNumber [String $ "#o" ++ s]+ 10 -> stringToNumber [String s]+ 16 -> stringToNumber [String $ "#x" ++ s]+ _ -> throwError $ Default $ "Invalid radix: " ++ show radix+stringToNumber [badType] = throwError $ TypeMismatch "string" badType+stringToNumber badArgList = throwError $ NumArgs 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++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++stringCopy :: [LispVal] -> ThrowsError LispVal+stringCopy [String s] = return $ String s+stringCopy [badType] = throwError $ TypeMismatch "string" badType+stringCopy badArgList = throwError $ NumArgs 2 badArgList++isDottedList :: [LispVal] -> ThrowsError LispVal+isDottedList ([DottedList _ _]) = return $ Bool True+-- Must include lists as well since they are made up of 'chains' of pairs+isDottedList ([List []]) = return $ Bool False+isDottedList ([List _]) = return $ Bool True+isDottedList _ = return $ Bool False++isProcedure :: [LispVal] -> ThrowsError LispVal+isProcedure ([Continuation _ _ _ _ _]) = return $ Bool True+isProcedure ([PrimitiveFunc _]) = return $ Bool True+isProcedure ([Func _ _ _ _]) = return $ Bool True+isProcedure ([IOFunc _]) = return $ Bool True+isProcedure ([EvalFunc _]) = return $ Bool True+isProcedure _ = return $ Bool False++isVector, isList :: LispVal -> ThrowsError LispVal+isVector (Vector _) = return $ Bool True+isVector _ = return $ Bool False+isList (List _) = return $ Bool True+isList _ = return $ Bool False++isNull :: [LispVal] -> ThrowsError LispVal+isNull ([List []]) = return $ Bool True+isNull _ = return $ Bool False++isEOFObject :: [LispVal] -> ThrowsError LispVal+isEOFObject ([EOF]) = return $ Bool True+isEOFObject _ = return $ Bool False++isSymbol :: [LispVal] -> ThrowsError LispVal+isSymbol ([Atom _]) = return $ Bool True+isSymbol _ = return $ Bool False++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++string2Symbol :: [LispVal] -> ThrowsError LispVal+string2Symbol ([String s]) = return $ Atom s+string2Symbol [] = throwError $ NumArgs 1 []+string2Symbol [notString] = throwError $ TypeMismatch "string" notString+string2Symbol args@(_ : _) = throwError $ NumArgs 1 args++isChar :: [LispVal] -> ThrowsError LispVal+isChar ([Char _]) = return $ Bool True+isChar _ = return $ Bool False++isString :: [LispVal] -> ThrowsError LispVal+isString ([String _]) = return $ Bool True+isString _ = return $ Bool False++isBoolean :: [LispVal] -> ThrowsError LispVal+isBoolean ([Bool _]) = return $ Bool True+isBoolean _ = return $ Bool False+++-- Utility functions+data Unpacker = forall a . Eq a => AnyUnpacker (LispVal -> ThrowsError a)++unpackEquals :: LispVal -> LispVal -> Unpacker -> ThrowsError Bool+unpackEquals arg1 arg2 (AnyUnpacker unpacker) =+ do unpacked1 <- unpacker arg1+ unpacked2 <- unpacker arg2+ return $ unpacked1 == unpacked2+ `catchError` (const $ return False)++boolBinop :: (LispVal -> ThrowsError a) -> (a -> a -> Bool) -> [LispVal] -> ThrowsError LispVal+boolBinop unpacker op args = if length args /= 2+ then throwError $ NumArgs 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++{- 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+unpackStr (String s) = return s+unpackStr (Number s) = return $ show s+unpackStr (Bool s) = return $ show s+unpackStr notString = throwError $ TypeMismatch "string" notString++unpackBool :: LispVal -> ThrowsError Bool+unpackBool (Bool b) = return b+unpackBool notBool = throwError $ TypeMismatch "boolean" notBool
hs-src/Language/Scheme/Variables.hs view
@@ -26,19 +26,17 @@ return $ Environment (Just envRef) bindinglist where addBinding ((namespace, name), val) = do ref <- newIORef val return ((namespace, name), ref)-{---- 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)--} +-- Recursively search environments to find one that contains var+findNamespacedEnv :: Env -> String -> String -> IO (Maybe Env)+findNamespacedEnv envRef namespace var = do+ found <- liftIO $ isNamespacedBound envRef namespace var+ if found+ then return (Just envRef)+ else case parentEnv envRef of+ (Just par) -> findNamespacedEnv par namespace var+ Nothing -> return Nothing+ -- |Determine if a variable is bound in the default namespace isBound :: Env -> String -> IO Bool isBound envRef var = isNamespacedBound envRef varNamespace var@@ -47,6 +45,14 @@ isNamespacedBound :: Env -> String -> String -> IO Bool isNamespacedBound envRef namespace var = (readIORef $ bindings envRef) >>= return . maybe False (const True) . lookup (namespace, var) +-- TODO: should isNamespacedBound be replaced with this? Probably, but one step at a time...+isNamespacedRecBound :: Env -> String -> String -> IO Bool+isNamespacedRecBound envRef namespace var = do+ env <- findNamespacedEnv envRef namespace var+ case env of+ (Just e) -> isNamespacedBound e namespace var+ Nothing -> return False+ -- |Retrieve the value of a variable defined in the default namespace getVar :: Env -> String -> IOThrowsError LispVal getVar envRef var = getNamespacedVar envRef varNamespace var@@ -61,6 +67,7 @@ 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
hs-src/shell.hs view
@@ -67,7 +67,7 @@ putStrLn " | | | | |_| \\__ \\ < /// \\\\\\ \\__ \\ (__| | | | __/ | | | | | __/ " putStrLn " |_| |_|\\__,_|___/_|\\_\\ /// \\\\\\ |___/\\___|_| |_|\\___|_| |_| |_|\\___| " putStrLn " "- putStrLn " husk Scheme Interpreter Version 3.0 "+ putStrLn " husk Scheme Interpreter Version 3.1 " putStrLn " (c) 2010-2011 Justin Ethier github.com/justinethier/husk-scheme " putStrLn " "
husk-scheme.cabal view
@@ -1,8 +1,8 @@ Name: husk-scheme-Version: 3.0+Version: 3.1 Synopsis: R5RS Scheme interpreter program and library. Description: A dialect of R5RS Scheme written in Haskell. Provides advanced - features including continuations, hygienic macros, a Haskell FFI,+ features including continuations, non-hygienic macros, a Haskell FFI, and the full numeric tower. License: MIT License-file: LICENSE@@ -29,6 +29,7 @@ Other-Modules: Language.Scheme.Macro Language.Scheme.Numerical Language.Scheme.Parser+ Language.Scheme.Primitives Executable huski Build-Depends: base >= 2.0 && < 5, array, containers, haskeline, haskell98, mtl, parsec, directory, ghc, ghc-paths@@ -41,3 +42,4 @@ Language.Scheme.Macro Language.Scheme.Numerical Language.Scheme.Parser+ Language.Scheme.Primitives
stdlib.scm view
@@ -68,9 +68,23 @@ (define (sum . lst) (fold + 0 lst)) (define (product . lst) (fold * 1 lst))-(define (and . lst) (fold && #t lst))-(define (or . lst) (fold || #f lst)) +; Forms from R5RS for and/or+(define-syntax and+ (syntax-rules ()+ ((and) #t)+ ((and test) test)+ ((and test1 test2 ...)+ (if test1 (and test2 ...) #f))))++(define-syntax or+ (syntax-rules ()+ ((or) #f)+ ((or test) test)+ ((or test1 test2 ...)+ (let ((x test1))+ (if x x (or test2 ...))))))+ (define (abs num) (if (negative? num) (* num -1)@@ -88,6 +102,72 @@ (define (length lst) (fold (lambda (x y) (+ x 1)) 0 lst)) (define (reverse lst) (fold (flip cons) '() lst)) +; cond+; Form from R5RS:+(define-syntax cond+ (syntax-rules (else =>)+ ((cond (else result1 result2 ...))+ (begin result1 result2 ...))+ ((cond (test => result))+ (let ((temp test))+ (if temp (result temp))))+ ((cond (test => result) clause1 clause2 ...)+ (let ((temp test))+ (if temp+ (result temp)+ (cond clause1 clause2 ...))))+ ((cond (test)) test)+ ((cond (test) clause1 clause2 ...)+ (let ((temp test))+ (if temp+ temp+ (cond clause1 clause2 ...))))+ ((cond (test result1 result2 ...))+ (if test (begin result1 result2 ...)))+ ((cond (test result1 result2 ...)+ clause1 clause2 ...)+ (if test+ (begin result1 result2 ...)+ (cond clause1 clause2 ...)))))+; Case+;+; TODO: form from R5RS:+;(define-syntax case+; (syntax-rules (else)+; ((case (key ...)+; clauses ...)+; (let ((atom-key (key ...)))+; (case atom-key clauses ...)))+; ((case key+; (else result1 result2 ...))+; (begin result1 result2 ...))+; ((case key+; ((atoms ...) result1 result2 ...))+; (if (memv key '(atoms ...))+; (begin result1 result2 ...)))+; ((case key+; ((atoms ...) result1 result2 ...)+; clause clauses ...)+; (if (memv key '(atoms ...))+; (begin result1 result2 ...)+; (case key clause clauses ...)))))+;+; Based loosely on implementation from:+; http://blog.jcoglan.com/2009/02/25/announcing-heist-a-new-scheme-implementation-written-in-ruby/+(define-syntax case+ (syntax-rules (else)+ ((_ key) ((lambda () #f)))+ ((_ key (else expr1 expr2 ...))+ (begin expr1 expr2 ...))+ ((_ key (() expr ...) clause ...)+ (case key clause ...))+ ((_ key+ ((datum1 datum2 ...) expr1 expr2 ...)+ clause ...)+ (if (eqv? #f (memv key '(datum1 datum2 ...)))+ (case key clause ...)+ (begin expr1 expr2 ...)))))+ (define (my-mem-helper obj lst cmp-proc) (cond ((null? lst) #f)@@ -161,25 +241,6 @@ (let* ((vars vals) ...) body))))) -; FUTURE: cond--; Case-;-; Based loosely on implementation from:-; http://blog.jcoglan.com/2009/02/25/announcing-heist-a-new-scheme-implementation-written-in-ruby/-(define-syntax case- (syntax-rules (else)- ((_ key) ((lambda () #f)))- ((_ key (else expr1 expr2 ...))- (begin expr1 expr2 ...))- ((_ key (() expr ...) clause ...)- (case key clause ...))- ((_ key- ((datum1 datum2 ...) expr1 expr2 ...)- clause ...)- (if (eqv? #f (memv key '(datum1 datum2 ...)))- (case key clause ...)- (begin expr1 expr2 ...))))) ; Iteration - do (define-syntax do