husk-scheme 3.3 → 3.4
raw patch · 8 files changed
+723/−279 lines, 8 filesdep ~haskell98
Dependency ranges changed: haskell98
Files
- README.markdown +3/−3
- hs-src/Language/Scheme/Core.hs +150/−72
- hs-src/Language/Scheme/Macro.hs +501/−192
- hs-src/Language/Scheme/Types.hs +14/−0
- hs-src/Language/Scheme/Variables.hs +43/−0
- hs-src/shell.hs +1/−1
- husk-scheme.cabal +4/−4
- stdlib.scm +7/−7
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, non-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, 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. @@ -24,8 +24,8 @@ - Standard library of Scheme functions - 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.-- 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.+- Continuations: First-class continuations of unlimited extent, call/cc, and call-with-values.+- Hygienic Macros: High-level macros via define-syntax - *Note this is still somewhat of a work in progress* - Macro support has improve significantly in the last few releases, and it works well enough that many derived forms are implemented in our standard library, but 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
@@ -32,7 +32,6 @@ import Data.Array import qualified Data.Map import IO hiding (try)---import Debug.Trace {- |Evaluate a string containing Scheme code. @@ -52,7 +51,7 @@ @ -} evalString :: Env -> String -> IO String-evalString env expr = runIOThrows $ liftM show $ (liftThrows $ readExpr expr) >>= macroEval env >>= (eval env (makeNullContinuation env))+evalString env expr = runIOThrows $ liftM show $ (liftThrows $ readExpr expr) >>= meval env (makeNullContinuation env) -- |Evaluate a string and print results to console evalAndPrint :: Env -> String -> IO ()@@ -61,9 +60,42 @@ {- |Evaluate lisp code that has already been loaded into haskell FUTURE: code example for this, via ghci and/or a custom Haskell program. -} evalLisp :: Env -> LispVal -> IOThrowsError LispVal-evalLisp env lisp = macroEval env lisp >>= (eval env (makeNullContinuation env))+evalLisp env lisp = meval env (makeNullContinuation env) lisp +-- |A wrapper for macroEval and eval+meval, mprepareApply :: Env -> LispVal -> LispVal -> IOThrowsError LispVal+meval env cont lisp = mfunc env cont lisp eval+mprepareApply env cont lisp = mfunc env cont lisp prepareApply+mfunc :: Env -> LispVal -> LispVal -> (Env -> LispVal -> LispVal -> IOThrowsError LispVal) -> IOThrowsError LispVal+mfunc env cont lisp func = do+ macroEval env lisp >>= (func env cont) +{- OBSOLETE:+ old code for updating env's in the continuation chain (see below)+ if False --needToExtendEnv lisp+ then do+ expanded <- macroEval env lisp+ exEnv <- liftIO $ extendEnv env []+ -- Recursively replace env of nextCont with the extended env+ -- This is more expensive than I would like, but I think it should be straightforward enough...+ exCont <- updateContEnv exEnv cont+ func exEnv (trace ("extending Env") exCont) expanded+ else macroEval env lisp >>= (func env cont) +-}+{- EXPERIMENTAL CODE FOR REPLACING ENV's in the continuation chain+ + This is a difficult problem to solve and this code will likely just+ end up going away because we are not going with this approach... +updateContEnv :: Env -> LispVal -> IOThrowsError LispVal+updateContEnv env (Continuation _ curC (Just nextC) xargs dwind) = do+ next <- updateContEnv env nextC+ return $ Continuation env curC (Just next) xargs dwind+updateContEnv env (Continuation _ curC Nothing xargs dwind) = do+ return $ Continuation env curC Nothing xargs dwind+updateContEnv _ val = do+ return val+-}+ {- continueEval is a support function for eval, below. - - Transformed eval section into CPS by calling into this instead of returning from eval.@@ -94,6 +126,7 @@ - when the computation is complete, you have to return something. -} continueEval _ (Continuation cEnv (Just (SchemeBody cBody)) (Just cCont) extraArgs dynWind) val = do+-- case (trace ("cBody = " ++ show cBody) cBody) of case cBody of [] -> do case cCont of@@ -101,8 +134,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] -> 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)+ [lv] -> meval cEnv (Continuation cEnv (Just (SchemeBody [])) (Just cCont) Nothing dynWind) lv+ (lv : lvs) -> meval cEnv (Continuation cEnv (Just (SchemeBody lvs)) (Just cCont) Nothing dynWind) lv -- No current continuation, but a next cont is available; call into it continueEval _ (Continuation cEnv Nothing (Just cCont) _ _) val = continueEval cEnv cCont val@@ -173,7 +206,7 @@ where cpsUnquote :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsUnquote e c val _ = do case val of- List [Atom "unquote", vval] -> macroEval e vval >>= eval e c+ List [Atom "unquote", vval] -> meval e c vval List (_ : _) -> doCpsUnquoteList e c val DottedList xs x -> do doCpsUnquoteList e (makeCPSWArgs e c cpsUnquotePair $ [x] ) $ List xs@@ -182,7 +215,7 @@ if len > 0 then doCpsUnquoteList e (makeCPS e c cpsUnquoteVector) $ List $ elems vec else continueEval e c $ Vector $ listArray (0, -1) []- _ -> macroEval e (List [Atom "quote", val]) >>= eval e c -- Behave like quote if there is nothing to "unquote"...+ _ -> meval e c (List [Atom "quote", val]) -- 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,@@ -218,7 +251,7 @@ cpsUnquoteList e c val (Just ([List unEvaled, List acc])) = do case val of List [Atom "unquote-splicing", vvar] -> do- macroEval e vvar >>= eval e (makeCPSWArgs e c cpsUnquoteSplicing $ [List unEvaled, List acc]) + meval e (makeCPSWArgs e c cpsUnquoteSplicing $ [List unEvaled, List acc]) vvar _ -> cpsUnquote e (makeCPSWArgs e c cpsUnquoteFld $ [List unEvaled, List acc]) val Nothing cpsUnquoteList _ _ _ _ = throwError $ InternalError "Unexpected parameters to cpsUnquoteList" @@ -240,112 +273,146 @@ _ -> cpsUnquoteList e c (head unEvaled) (Just [List (tail unEvaled), List $ acc ++ [val] ]) cpsUnquoteFld _ _ _ _ = throwError $ InternalError "Unexpected parameters to cpsUnquoteFld" +-- TODO: let-syntax+--+-- high-level design +-- - use extendEnv to create a new environment+-- - read all macros into new Syntax objects in the new env+-- - pick up execution of the body, perhaps just like how it is+-- done today with a function body+--++eval env cont args@(List [Atom "define-syntax", Atom keyword, (List (Atom "syntax-rules" : (List identifiers : rules)))]) = do+ bound <- liftIO $ isRecBound env "define-syntax"+ if bound+ then prepareApply env cont args -- if bound to a variable in this scope; call into it+ else do + {-+ - FUTURE: Issue #15: there really ought to be some error checking of the syntax rules, + - since they could be malformed...+ - As it stands now, there is no checking until the code attempts to perform a macro transformation.+ - At a minimum, should check identifiers to make sure each is an atom (see findAtom) + -}+ -- + -- I think it seems to be a better solution to use this defEnv, but+ -- that causes problems when a var is changed via (define) or (set!) since most+ -- schemes interpret allow this change to propagate back to the point of definition+ -- (or at least, when modules are not in play). See:+ --+ -- http://stackoverflow.com/questions/7999084/scheme-syntax-rules-difference-in-variable-bindings-between-let-anddefine+ --+ -- Anyway, this may come back. But not using it for now...+ --+ -- defEnv <- liftIO $ copyEnv env+ _ <- defineNamespacedVar env macroNamespace keyword $ Syntax env identifiers rules+ return $ Nil "" -- Sentinel value+ eval env cont args@(List [Atom "if", predic, conseq, alt]) = do- bound <- liftIO $ isBound env "if"+ bound <- liftIO $ isRecBound 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)+ else meval env (makeCPS env cont cps) predic where cps :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cps e c result _ = case (result) of- Bool False -> macroEval e alt >>= eval e c- _ -> macroEval e conseq >>= eval e c+ Bool False -> meval e c alt+ _ -> meval e c conseq eval env cont args@(List [Atom "if", predic, conseq]) = do- bound <- liftIO $ isBound env "if"+ bound <- liftIO $ isRecBound 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)+ else meval env (makeCPS env cont cpsResult) predic where cpsResult :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsResult e c result _ = case result of- Bool True -> macroEval e conseq >>= eval e c+ Bool True -> meval e c conseq _ -> continueEval e c $ Nil "" -- Unspecified return value per R5RS eval env cont fargs@(List (Atom "begin" : funcs)) = do- bound <- liftIO $ isBound env "begin"+ bound <- liftIO $ isRecBound 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+ then meval env cont (Nil "") 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)+ then meval env cont (head funcs)+ else meval env (makeCPSWArgs env cont cpsRest $ tail funcs) (head funcs) where cpsRest :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsRest e c _ args = case args of- Just fArgs -> macroEval e (List (Atom "begin" : fArgs)) >>= eval e c + Just fArgs -> meval e c (List (Atom "begin" : fArgs)) Nothing -> throwError $ Default "Unexpected error in begin" eval env cont args@(List [Atom "set!", Atom var, form]) = do- bound <- liftIO $ isBound env "set!"+ bound <- liftIO $ isRecBound 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)+ else meval env (makeCPS env cont cpsResult) form where cpsResult :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsResult e c result _ = setVar e var result >>= continueEval e c eval env cont args@(List [Atom "set!", nonvar, _]) = do - bound <- liftIO $ isBound env "set!"+ bound <- liftIO $ isRecBound 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!"+ bound <- liftIO $ isRecBound env "set!" if bound then prepareApply env cont fargs -- if is bound to a variable in this scope; call into it else throwError $ NumArgs 2 args eval env cont args@(List [Atom "define", Atom var, form]) = do- bound <- liftIO $ isBound env "define"+ bound <- liftIO $ isRecBound env "define" if bound then prepareApply env cont args -- if is bound to a variable in this scope; call into it- else macroEval env form >>= eval env (makeCPS env cont cpsResult)+ else meval env (makeCPS env cont cpsResult) form where cpsResult :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsResult e c result _ = defineVar e var result >>= continueEval e c eval env cont args@(List (Atom "define" : List (Atom var : fparams) : fbody )) = do- bound <- liftIO $ isBound env "define"+ bound <- liftIO $ isRecBound env "define" if bound then prepareApply env cont args -- if is bound to a variable in this scope; call into it else do result <- (makeNormalFunc env fparams fbody >>= defineVar env var) continueEval env cont result eval env cont args@(List (Atom "define" : DottedList (Atom var : fparams) varargs : fbody)) = do- bound <- liftIO $ isBound env "define"+ bound <- liftIO $ isRecBound env "define" if bound then prepareApply env cont args -- if is bound to a variable in this scope; call into it else do result <- (makeVarargs varargs env fparams fbody >>= defineVar env var) continueEval env cont result eval env cont args@(List (Atom "lambda" : List fparams : fbody)) = do- bound <- liftIO $ isBound env "lambda"+ bound <- liftIO $ isRecBound 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 args@(List (Atom "lambda" : DottedList fparams varargs : fbody)) = do- bound <- liftIO $ isBound env "lambda"+ bound <- liftIO $ isRecBound 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 args@(List (Atom "lambda" : varargs@(Atom _) : fbody)) = do- bound <- liftIO $ isBound env "lambda"+ bound <- liftIO $ isRecBound 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 args@(List [Atom "string-set!", Atom var, i, character]) = do- bound <- liftIO $ isBound env "string-set!"+ bound <- liftIO $ isRecBound 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)+ else meval env (makeCPS env cont cpsStr) i where cpsStr :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal- cpsStr e c idx _ = (macroEval e =<< getVar e var) >>= eval e (makeCPSWArgs e c cpsSubStr $ [idx])+ cpsStr e c idx _ = (meval e (makeCPSWArgs e c cpsSubStr $ [idx]) =<< getVar e var) cpsSubStr :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsSubStr e c str (Just [idx]) =@@ -360,26 +427,26 @@ substr (String _, c, _) = throwError $ TypeMismatch "character" c substr (s, _, _) = throwError $ TypeMismatch "string" s eval env cont args@(List [Atom "string-set!" , nonvar , _ , _ ]) = do- bound <- liftIO $ isBound env "string-set!"+ bound <- liftIO $ isRecBound 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!"+ bound <- liftIO $ isRecBound env "string-set!" if bound then prepareApply env cont fargs -- if is bound to a variable in this scope; call into it else throwError $ NumArgs 3 args eval env cont args@(List [Atom "set-car!", Atom var, argObj]) = do- bound <- liftIO $ isBound env "set-car!"+ bound <- liftIO $ isRecBound 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 (_ : _)) _ = 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 e c obj@(List (_ : _)) _ = meval e (makeCPSWArgs e c cpsSet $ [obj]) argObj+ cpsObj e c obj@(DottedList _ _) _ = meval e (makeCPSWArgs e c cpsSet $ [obj]) argObj cpsObj _ _ obj _ = throwError $ TypeMismatch "pair" obj cpsSet :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal@@ -387,26 +454,26 @@ 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 env cont args@(List [Atom "set-car!" , nonvar , _ ]) = do- bound <- liftIO $ isBound env "set-car!"+ bound <- liftIO $ isRecBound 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!"+ bound <- liftIO $ isRecBound env "set-car!" if bound then prepareApply env cont fargs -- if is bound to a variable in this scope; call into it else throwError $ NumArgs 2 args eval env cont args@(List [Atom "set-cdr!", Atom var, argObj]) = do- bound <- liftIO $ isBound env "set-cdr!"+ bound <- liftIO $ isRecBound 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 (_ : _)) _ = 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 e c pair@(List (_ : _)) _ = meval e (makeCPSWArgs e c cpsSet $ [pair]) argObj+ cpsObj e c pair@(DottedList _ _) _ = meval e (makeCPSWArgs e c cpsSet $ [pair]) argObj cpsObj _ _ pair _ = throwError $ TypeMismatch "pair" pair cpsSet :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal@@ -414,27 +481,27 @@ cpsSet e c obj (Just [DottedList (l : _) _]) = setVar e var (DottedList [l] obj) >>= continueEval e c cpsSet _ _ _ _ = throwError $ InternalError "Unexpected argument to cpsSet" eval env cont args@(List [Atom "set-cdr!" , nonvar , _ ]) = do- bound <- liftIO $ isBound env "set-cdr!"+ bound <- liftIO $ isRecBound 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!"+ bound <- liftIO $ isRecBound env "set-cdr!" if bound then prepareApply env cont fargs -- if is bound to a variable in this scope; call into it else throwError $ NumArgs 2 args eval env cont args@(List [Atom "vector-set!", Atom var, i, object]) = do- bound <- liftIO $ isBound env "vector-set!"+ bound <- liftIO $ isRecBound 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)+ else meval env (makeCPS env cont cpsObj) i where cpsObj :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal- cpsObj e c idx _ = macroEval e object >>= eval e (makeCPSWArgs e c cpsVec $ [idx])+ cpsObj e c idx _ = meval e (makeCPSWArgs e c cpsVec $ [idx]) object cpsVec :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal- cpsVec e c obj (Just [idx]) = (macroEval e =<< getVar e var) >>= eval e (makeCPSWArgs e c cpsUpdateVec $ [idx, obj])+ cpsVec e c obj (Just [idx]) = (meval e (makeCPSWArgs e c cpsUpdateVec $ [idx, obj]) =<< getVar e var) cpsVec _ _ _ _ = throwError $ InternalError "Invalid argument to cpsVec" cpsUpdateVec :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal@@ -446,75 +513,75 @@ updateVector (Vector vec) (Number idx) obj = return $ Vector $ vec // [(fromInteger idx, obj)] updateVector v _ _ = throwError $ TypeMismatch "vector" v eval env cont args@(List [Atom "vector-set!" , nonvar , _ , _]) = do - bound <- liftIO $ isBound env "vector-set!"+ bound <- liftIO $ isRecBound 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!"+ bound <- liftIO $ isRecBound env "vector-set!" if bound then prepareApply env cont fargs -- if is bound to a variable in this scope; call into it else throwError $ NumArgs 3 args eval env cont args@(List [Atom "hash-table-set!", Atom var, rkey, rvalue]) = do- bound <- liftIO $ isBound env "hash-table-set!"+ bound <- liftIO $ isRecBound 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)+ else meval env (makeCPS env cont cpsValue) rkey where cpsValue :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal- cpsValue e c key _ = macroEval e rvalue >>= eval e (makeCPSWArgs e c cpsH $ [key]) + cpsValue e c key _ = meval e (makeCPSWArgs e c cpsH $ [key]) rvalue cpsH :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal- cpsH e c value (Just [key]) = (macroEval e =<< getVar e var) >>= eval e (makeCPSWArgs e c cpsEvalH $ [key, value])+ cpsH e c value (Just [key]) = (meval e (makeCPSWArgs e c cpsEvalH $ [key, value]) =<< getVar e var) 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) >>= macroEval e >>= eval e c+ setVar env var (HashTable $ Data.Map.insert key value ht) >>= meval e c other -> throwError $ TypeMismatch "hash-table" other cpsEvalH _ _ _ _ = throwError $ InternalError "Invalid argument to cpsEvalH" eval env cont args@(List [Atom "hash-table-set!" , nonvar , _ , _]) = do- bound <- liftIO $ isBound env "hash-table-set!"+ bound <- liftIO $ isRecBound 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!"+ bound <- liftIO $ isRecBound env "hash-table-set!" if bound then prepareApply env cont fargs -- if is bound to a variable in this scope; call into it else throwError $ NumArgs 3 args eval env cont args@(List [Atom "hash-table-delete!", Atom var, rkey]) = do- bound <- liftIO $ isBound env "hash-table-delete!"+ bound <- liftIO $ isRecBound 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)+ else meval env (makeCPS env cont cpsH) rkey where cpsH :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal- cpsH e c key _ = (macroEval e =<< getVar e var) >>= eval e (makeCPSWArgs e c cpsEvalH $ [key])+ cpsH e c key _ = (meval e (makeCPSWArgs e c cpsEvalH $ [key]) =<< getVar e var) 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) >>= macroEval e >>= eval e c+ setVar env var (HashTable $ Data.Map.delete key ht) >>= meval e c other -> throwError $ TypeMismatch "hash-table" other cpsEvalH _ _ _ _ = throwError $ InternalError "Invalid argument to cpsEvalH" eval env cont args@(List [Atom "hash-table-delete!" , nonvar , _]) = do- bound <- liftIO $ isBound env "hash-table-delete!"+ bound <- liftIO $ isRecBound 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!"+ bound <- liftIO $ isRecBound env "hash-table-delete!" if bound then prepareApply env cont fargs -- if is bound to a variable in this scope; call into it else throwError $ NumArgs 2 args -eval env cont args@(List (_ : _)) = macroEval env args >>= prepareApply env cont+eval env cont args@(List (_ : _)) = mprepareApply env cont args eval _ _ badForm = throwError $ BadSpecialForm "Unrecognized special form" badForm {- Prepare for apply by evaluating each function argument,@@ -527,8 +594,8 @@ -- case (trace ("prep eval of args: " ++ show args) args) of case (args) of [] -> apply c func [] -- No args, immediately apply the function- [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])+ [a] -> meval env (makeCPSWArgs e c cpsEvalArgs $ [func, List [], List []]) a+ (a : as) -> meval env (makeCPSWArgs e c cpsEvalArgs $ [func, List [], List as]) a 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@@ -540,8 +607,8 @@ cpsEvalArgs e c evaledArg (Just [func, List argsEvaled, List argsRemaining]) = case argsRemaining of [] -> apply c func (argsEvaled ++ [evaledArg])- [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])+ [a] -> meval e (makeCPSWArgs e c cpsEvalArgs $ [func, List (argsEvaled ++ [evaledArg]), List []]) a+ (a : as) -> meval e (makeCPSWArgs e c cpsEvalArgs $ [func, List (argsEvaled ++ [evaledArg]), List as]) a cpsEvalArgs _ _ _ (Just _) = throwError $ Default "Unexpected error in function application (1)" cpsEvalArgs _ _ _ Nothing = throwError $ Default "Unexpected error in function application (2)"@@ -691,12 +758,23 @@ evalfuncApply _ = throwError $ NumArgs 2 [] evalfuncLoad [cont@(Continuation env _ _ _ _), String filename] = do+{-+-- It would be nice to use CPS style below.+--+-- This code mostly works, but causes looping problems in t-cont. need to test to see if+-- those are an artifact of this change or a code problem in that test suite:+ code <- load filename+ if not (null code)+ then continueEval env (Continuation env (Just $ SchemeBody code) (Just cont) Nothing Nothing) $ Nil "" + else return $ Nil "" -- Empty, unspecified value+-} results <- load filename >>= mapM (evaluate env (makeNullContinuation env)) if not (null results) then do result <- return . last $ results continueEval env cont result else return $ Nil "" -- Empty, unspecified value- where evaluate env2 cont2 val2 = macroEval env2 val2 >>= eval env2 cont2+ where evaluate env2 cont2 val2 = meval env2 cont2 val2+ evalfuncLoad (_ : args) = throwError $ NumArgs 1 args -- Skip over continuation argument evalfuncLoad _ = throwError $ NumArgs 1 [] @@ -707,7 +785,7 @@ -- -- FUTURE: consider allowing env to be specified, per R5RS ---evalfuncEval [cont@(Continuation env _ _ _ _), val] = macroEval env val >>= eval env cont+evalfuncEval [cont@(Continuation env _ _ _ _), val] = meval env cont val evalfuncEval (_ : args) = throwError $ NumArgs 1 args -- Skip over continuation argument evalfuncEval _ = throwError $ NumArgs 1 []
hs-src/Language/Scheme/Macro.hs view
@@ -13,17 +13,26 @@ This module contains code for hygienic macros. -During transformation, the following components are considered:+Hygienic macros are implemented using the algorithm from the paper+Macros That Work by William Clinger and Jonathan Rees. During +transformation, the following components are considered:+ - Pattern (part of a rule that matches input) - Transform (what the macro "expands" into)+ - Literal Identifiers (from the macro definition) - Input (the actual code in the user's program)+ - Environments of macro definition and macro use At a high level, macro transformation is broken down into the following steps: 1) Search for a rule that matches the input.- During this process, any variables in the input are loaded into a temporary environment+ During this process, any pattern variables in the input are loaded into a temporary environment 2) If a rule matches,- 3) Transform by walking the transform, inserting variables as needed+ 3) Transcribe the rule's template by walking the template, inserting pattern variables + and renaming free identifiers as needed.+ 4) Walk the expanded code, checking for each of the cases from Macros That Work. If a + case is found (such as a macro call or procedure abstraction) then the appropriate + handler will be called to deal with it. -} @@ -34,6 +43,7 @@ import Language.Scheme.Types import Language.Scheme.Variables import qualified Language.Scheme.Macro.Matches as Matches+import Language.Scheme.Primitives (_gensym) import Control.Monad.Error import Data.Array --import Debug.Trace -- Only req'd to support trace, can be disabled at any time...@@ -44,28 +54,50 @@ 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. -}-macroEval :: Env -> LispVal -> IOThrowsError LispVal+--+-- Notes regarding other side of hygiene.+--+-- !!!+-- Turns out this was unnecessary because it is sufficient to simply save the environment of+-- definition directly. Even though this causes problems with define, it seems that is how+-- other Schemes work, so it will stay that way for now. This note is being kept for the +-- moment although it should probably go away... in any case only take it as brainstorming+-- notes and nothing further:+-- !!!+--+-- In order to handle the 'other side', the env at macro definition needs to be saved. It+-- will be used again when a macro is expanded. The pattern matcher will compare any named+-- identifiers it finds against both environments to ensure identifiers were not redefined.+--+-- Also, during rewrite identifiers are supposed to be read out of envDef. They are then +-- diverted into envUse at the end of the macro transcription (in other words, once an+-- instance of rewrite is finished).+--+-- So... how do we preserve envDef? One idea is to create a deep copy of the env during+-- macro definition, but this could be error prone and expensive. Another idea is to+-- call extendEnv to create a new environment on top of envDef. This new environment+-- would then need to be passed along to eval (and presumably its current/next continuations).+--+-- This should work because any env changes would only affect the new environment and not+-- the parent one. The disadvantage is that macroEval is called in several places in Core.+-- It's calls will need to be modified to use a new function that will pass along the+-- extended env if necessary. I am a bit concerned about suble errors occuring if any+-- continuations in the chain are not updated and still have the old environment in them.+-- It may be tricky to get this right. But otherwise the change *should* be straightforward. --- Special case, just load up the syntax rules-macroEval env (List [Atom "define-syntax", Atom keyword, syntaxRules@(List (Atom "syntax-rules" : (List _ : _)))]) = do- {-- - FUTURE: Issue #15: there really ought to be some error checking of the syntax rules, - - since they could be malformed...- - As it stands now, there is no checking until the code attempts to perform a macro transformation.- - At a minimum, should check identifiers to make sure each is an atom (see findAtom) - -}- _ <- defineNamespacedVar env macroNamespace keyword syntaxRules- return $ Nil "" -- Sentinal value +-- Currently unused, and likely to go away:+-- A support function for Core that will be used as part of the above...+--needToExtendEnv :: LispVal -> Bool --IOThrowsError LispVal+--needToExtendEnv (List [Atom "define-syntax", Atom _, (List (Atom "syntax-rules" : (List _ : _)))]) = True+--needToExtendEnv _ = False ++-- |macroEval+-- Search for macro's in the AST, and transform any that are found.+macroEval :: Env -> LispVal -> IOThrowsError LispVal+ {- Inspect code for macros - - Only a list form is required because a pattern may only consist@@ -76,14 +108,20 @@ - -} macroEval env lisp@(List (Atom x : _)) = do+ -- Note: If there is a procedure of the same name it will be shadowed by the macro. 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 + if isDefined then do- (List (Atom "syntax-rules" : (List identifiers : rules))) <- getNamespacedVar env macroNamespace x+ Syntax defEnv identifiers rules <- getNamespacedVar env macroNamespace x+ renameEnv <- liftIO $ nullEnv -- Local environment used just for this invocation+ -- to hold renamed variables+ cleanupEnv <- liftIO $ nullEnv -- Local environment used just for this invocation+ -- to hold new symbols introduced by renaming. We+ -- can use this to clean up any left after transformation+ -- Transform the input and then call macroEval again, since a macro may be contained within...- macroEval env =<< macroTransform env (List identifiers) rules lisp+ expanded <- macroTransform defEnv env renameEnv cleanupEnv (List identifiers) rules lisp+ macroEval env expanded -- Useful debug to see all exp's: (trace ("exp = " ++ show expanded) expanded) else return lisp -- No macro to process, just return code as it is...@@ -101,16 +139,20 @@ - rules - pattern/transform pairs to compare to input - input - Code from the scheme application -}-macroTransform :: Env -> LispVal -> [LispVal] -> LispVal -> IOThrowsError LispVal-macroTransform env identifiers (rule@(List _) : rs) input = do+macroTransform :: Env -> Env -> Env -> Env -> LispVal -> [LispVal] -> LispVal -> IOThrowsError LispVal+macroTransform defEnv env renameEnv cleanupEnv identifiers (rule@(List _) : rs) input = do localEnv <- liftIO $ nullEnv -- Local environment used just for this invocation- result <- matchRule env identifiers localEnv rule input+ -- to hold pattern variables+ result <- matchRule defEnv env identifiers localEnv renameEnv cleanupEnv rule input case result of- Nil _ -> macroTransform env identifiers rs input- _ -> return result+ -- No match, check the next rule+ Nil _ -> macroTransform defEnv env renameEnv cleanupEnv identifiers rs input+ _ -> do+ -- Walk the resulting code, performing the Clinger algorithm's 4 components+ walkExpanded defEnv env renameEnv cleanupEnv True False (List []) (result) -- Ran out of rules to match...-macroTransform _ _ _ input = throwError $ BadSpecialForm "Input does not match a macro pattern" input+macroTransform _ _ _ _ _ _ input = throwError $ BadSpecialForm "Input does not match a macro pattern" input -- Determine if the next element in a list matches 0-to-n times due to an ellipsis macroElementMatchesMany :: LispVal -> Bool@@ -124,8 +166,8 @@ {- 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 outerEnv identifiers localEnv (List [pattern, template]) (List inputVar) = do+matchRule :: Env -> Env -> LispVal -> Env -> Env -> Env -> LispVal -> LispVal -> IOThrowsError LispVal+matchRule defEnv outerEnv identifiers localEnv renameEnv cleanupEnv (List [pattern, template]) (List inputVar) = do let is = tail inputVar let p = case pattern of DottedList ds d -> case ds of@@ -140,8 +182,7 @@ case match of Bool False -> return $ Nil "" _ -> do--- bindings <- findBindings localEnv pattern- transformRule outerEnv localEnv 0 [] (List []) template+ transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers 0 [] (List []) template _ -> throwError $ BadSpecialForm "Malformed rule in syntax-rules" $ String $ show p where@@ -150,48 +191,29 @@ checkPattern ps@(DottedList ds d : _) is True = do case is of (DottedList _ _ : _) -> do - loadLocal outerEnv localEnv identifiers + loadLocal defEnv outerEnv localEnv renameEnv identifiers (List $ ds ++ [d, Atom "..."]) (List is) 0 [] (flagDottedLists [] (False, False) 0) (List _ : _) -> do - loadLocal outerEnv localEnv identifiers + loadLocal defEnv outerEnv localEnv renameEnv identifiers (List $ ds ++ [d, Atom "..."]) (List is) 0 [] (flagDottedLists [] (True, False) 0)- _ -> loadLocal outerEnv localEnv identifiers (List ps) (List is) 0 [] []+ _ -> loadLocal defEnv outerEnv localEnv renameEnv identifiers (List ps) (List is) 0 [] [] -- No pair, immediately begin matching- checkPattern ps is _ = loadLocal outerEnv localEnv identifiers (List ps) (List is) 0 [] [] + checkPattern ps is _ = loadLocal defEnv outerEnv localEnv renameEnv identifiers (List ps) (List is) 0 [] [] -matchRule _ _ _ rule input = do+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 -> Env -> LispVal -> LispVal -> LispVal -> Int -> [Int] -> [(Bool, Bool)] -> IOThrowsError LispVal-loadLocal outerEnv localEnv identifiers pattern input ellipsisLevel ellipsisIndex listFlags = do+loadLocal :: Env -> Env -> Env -> Env -> LispVal -> LispVal -> LispVal -> Int -> [Int] -> [(Bool, Bool)] -> IOThrowsError LispVal+loadLocal defEnv outerEnv localEnv renameEnv identifiers pattern input ellipsisLevel ellipsisIndex listFlags = do case (pattern, input) of ((DottedList ps p), (DottedList isRaw iRaw)) -> do@@ -203,11 +225,11 @@ let is = fst isSplit let i = (snd isSplit) ++ [iRaw] - result <- loadLocal outerEnv localEnv identifiers (List ps) (List is) ellipsisLevel ellipsisIndex listFlags+ result <- loadLocal defEnv outerEnv localEnv renameEnv identifiers (List ps) (List is) ellipsisLevel ellipsisIndex listFlags case result of Bool True -> -- By matching on an elipsis we force the code -- to match pagainst all elements in i. - loadLocal outerEnv localEnv identifiers + loadLocal defEnv outerEnv localEnv renameEnv identifiers (List $ [p, Atom "..."]) (List i) ellipsisLevel -- Incremented in the list/list match below@@ -231,7 +253,7 @@ else ellipsisIndex -- At this point we know if the input is part of an ellipsis, so set the level accordingly - status <- checkLocal outerEnv (localEnv) identifiers level idx p i listFlags+ status <- checkLocal defEnv outerEnv (localEnv) renameEnv identifiers level idx p i listFlags case (status) of -- No match Bool False -> if nextHasEllipsis@@ -240,16 +262,16 @@ then do case ps of [Atom "..."] -> return $ Bool True -- An otherwise empty list, so just let the caller know match is done- _ -> loadLocal outerEnv localEnv identifiers (List $ tail ps) (List (i : is)) ellipsisLevel ellipsisIndex listFlags+ _ -> loadLocal defEnv outerEnv localEnv renameEnv identifiers (List $ tail ps) (List (i : is)) ellipsisLevel ellipsisIndex listFlags else return $ Bool False -- There was a match _ -> if nextHasEllipsis then - loadLocal outerEnv localEnv identifiers pattern (List is)+ loadLocal defEnv outerEnv localEnv renameEnv identifiers pattern (List is) ellipsisLevel -- Do not increment level, just wait until the next go-round when it will be incremented above idx -- Must keep index since it is incremented each time listFlags- else loadLocal outerEnv localEnv identifiers (List ps) (List is) ellipsisLevel ellipsisIndex listFlags+ else loadLocal defEnv outerEnv localEnv renameEnv identifiers (List ps) (List is) ellipsisLevel ellipsisIndex listFlags -- Base case - All data processed (List [], List []) -> return $ Bool True@@ -263,14 +285,14 @@ -- Note: -- Appending to eIndex to compensate for fact we are outside the list containing the nary match let flags = getListFlags (ellipsisIndex ++ [0]) listFlags- flagUnmatchedVars outerEnv localEnv identifiers pattern $ fst flags+ flagUnmatchedVars defEnv outerEnv localEnv identifiers pattern $ fst flags else return $ Bool False -- Pattern ran out, but there is still input. No match. (List [], _) -> return $ Bool False -- Check input against pattern (both should be single var)- (_, _) -> checkLocal outerEnv localEnv identifiers ellipsisLevel ellipsisIndex pattern input listFlags+ (_, _) -> checkLocal defEnv outerEnv localEnv renameEnv identifiers ellipsisLevel ellipsisIndex pattern input listFlags -- -- |Utility function to flag pattern variables as 'no match' that exist in the @@ -282,42 +304,43 @@ -- This information is necessary for use during transformation, where the output may -- change depending upon the form of the input. ---flagUnmatchedVars :: Env -> Env -> LispVal -> LispVal -> Bool -> IOThrowsError LispVal +flagUnmatchedVars :: Env -> Env -> Env -> LispVal -> LispVal -> Bool -> IOThrowsError LispVal -flagUnmatchedVars outerEnv localEnv identifiers (DottedList ps p) partOfImproperPattern = do- flagUnmatchedVars outerEnv localEnv identifiers (List $ ps ++ [p]) partOfImproperPattern+flagUnmatchedVars defEnv outerEnv localEnv identifiers (DottedList ps p) partOfImproperPattern = do+ flagUnmatchedVars defEnv outerEnv localEnv identifiers (List $ ps ++ [p]) partOfImproperPattern -flagUnmatchedVars outerEnv localEnv identifiers (Vector p) partOfImproperPattern = do- flagUnmatchedVars outerEnv localEnv identifiers (List $ elems p) partOfImproperPattern+flagUnmatchedVars defEnv outerEnv localEnv identifiers (Vector p) partOfImproperPattern = do+ flagUnmatchedVars defEnv outerEnv localEnv identifiers (List $ elems p) partOfImproperPattern -flagUnmatchedVars _ _ _ (List []) _ = return $ Bool True +flagUnmatchedVars _ _ _ _ (List []) _ = return $ Bool True -flagUnmatchedVars outerEnv localEnv identifiers (List (p : ps)) partOfImproperPattern = do- _ <- flagUnmatchedVars outerEnv localEnv identifiers p partOfImproperPattern- flagUnmatchedVars outerEnv localEnv identifiers (List ps) partOfImproperPattern+flagUnmatchedVars defEnv outerEnv localEnv identifiers (List (p : ps)) partOfImproperPattern = do+ _ <- flagUnmatchedVars defEnv outerEnv localEnv identifiers p partOfImproperPattern+ flagUnmatchedVars defEnv outerEnv localEnv identifiers (List ps) partOfImproperPattern -flagUnmatchedVars _ _ _ (Atom "...") _ = return $ Bool True +flagUnmatchedVars _ _ _ _ (Atom "...") _ = return $ Bool True -flagUnmatchedVars outerEnv localEnv identifiers (Atom p) partOfImproperPattern =- flagUnmatchedAtom outerEnv localEnv identifiers p partOfImproperPattern+flagUnmatchedVars defEnv outerEnv localEnv identifiers (Atom p) partOfImproperPattern =+ flagUnmatchedAtom defEnv outerEnv localEnv identifiers p partOfImproperPattern -flagUnmatchedVars _ _ _ _ _ = return $ Bool True +flagUnmatchedVars _ _ _ _ _ _ = return $ Bool True -- |Flag an atom that did not have any matching input -- -- Note that an atom may not be flagged in certain cases, for example if -- the var is lexically defined in the outer environment. This logic -- matches that in the pattern matching code.-flagUnmatchedAtom :: Env -> Env -> LispVal -> String -> Bool -> IOThrowsError LispVal -flagUnmatchedAtom outerEnv localEnv identifiers p improperListFlag = do+flagUnmatchedAtom :: Env -> Env -> Env -> LispVal -> String -> Bool -> IOThrowsError LispVal +flagUnmatchedAtom defEnv outerEnv localEnv identifiers p improperListFlag = do isDefined <- liftIO $ isBound localEnv p- isLexicallyDefinedVar <- liftIO $ isBound outerEnv p isIdent <- findAtom (Atom p) identifiers if isDefined -- Var already defined, skip it... then continueFlagging else case isIdent of- Bool True -> if isLexicallyDefinedVar -- Is this good enough?+ Bool True -> do+ matches <- identifierMatches defEnv outerEnv p+ if not matches then return $ Bool True else do _ <- flagUnmatchedVar localEnv p improperListFlag continueFlagging@@ -348,8 +371,10 @@ | otherwise = (False, False) -- Check pattern against input to determine if there is a match-checkLocal :: Env -- Outer environment where this macro was called+checkLocal :: Env -- Environment where the macro was defined+ -> Env -- Outer environment where this macro was called -> Env -- Local environment used to store temporary variables for macro processing+ -> Env -- Local environment used to store vars that have been renamed by the macro subsystem -> LispVal -- List of identifiers specified in the syntax-rules -> Int -- Current nary (ellipsis) level -> [Int] -- Ellipsis Index, keeps track of the current nary (ellipsis) depth at each level @@ -357,19 +382,30 @@ -> LispVal -- Input to be matched -> [(Bool, Bool)] -- Flags to determine whether input pattern/variables are proper lists -> 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 ellipsisLevel ellipsisIndex (Atom pattern) input listFlags = do+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 defEnv outerEnv localEnv renameEnv identifiers ellipsisLevel ellipsisIndex (Atom pattern) input listFlags = do++ -- TODO: + --+ -- The code below uses this rename boolean as a factor to determine whether a named+ -- identifier has been redefined and thus should not match itself in the input. But the+ -- thing is, the actual code is supposed to compare the value at macro definition+ -- time with the value in the environment of use (outerEnv) to make this determination.+ -- So what is below is close but not truly correct.+ --+ isRenamed <- liftIO $ isRecBound renameEnv (pattern)+ doesIdentMatch <- identifierMatches defEnv outerEnv pattern+ if (ellipsisLevel) > 0 {- 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)@@ -381,7 +417,7 @@ case input of Atom inpt -> do if (pattern == inpt) - then if isLexicallyDefinedVar == False + then if (doesIdentMatch) && (not isRenamed) -- Var is not bound in outer code; proceed then do -- Set variable in the local environment@@ -403,14 +439,15 @@ -- else do isIdent <- findAtom (Atom pattern) identifiers- isLexicallyDefinedPatternVar <- liftIO $ isBound outerEnv pattern -- Var defined in scope outside macro+ --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 && (not isLexicallyDefinedPatternVar)) -- Regarding lex binding; see above, sec 4.3.2 from spec+ if (pattern == inpt && (doesIdentMatch)) && (not isRenamed) -- Regarding lex binding; see above, sec 4.3.2 from spec+-- if (pattern == inpt && (not isLexicallyDefinedPatternVar)) && (not isRenamed) -- Regarding lex binding; see above, sec 4.3.2 from spec then do _ <- defineVar localEnv pattern input return $ Bool True else return $ (Bool False)@@ -420,30 +457,13 @@ -- 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 ((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 -- Store pattern variable in a nested list -- FUTURE: ellipsisLevel should probably be used here for validation. -- - -- some notes: (above): need to flag the ellipsisLevel of this variable.- -- also, it is an error if, for an existing var, ellipsisLevel input does not match the var's stored level+ -- some notes:+ -- (above): need to flag the ellipsisLevel of this variable.+ -- also, it is an error if, for an existing var, ellipsisLevel input does not match the var's stored level -- addPatternVar isDefined ellipLevel ellipIndex pat val | isDefined = do v <- getVar localEnv pat@@ -473,31 +493,234 @@ _ <- defineNamespacedVar localEnv "improper pattern" pat $ Bool $ fst flags defineNamespacedVar localEnv "improper input" pat $ Bool $ snd flags -checkLocal outerEnv localEnv identifiers ellipsisLevel ellipsisIndex (Vector p) (Vector i) flags =+checkLocal defEnv outerEnv localEnv renameEnv identifiers ellipsisLevel ellipsisIndex (Vector p) (Vector i) flags = -- 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. -}- loadLocal outerEnv localEnv identifiers (List $ elems p) (List $ elems i) ellipsisLevel ellipsisIndex flags+ loadLocal defEnv outerEnv localEnv renameEnv identifiers (List $ elems p) (List $ elems i) ellipsisLevel ellipsisIndex flags -checkLocal outerEnv localEnv identifiers ellipsisLevel ellipsisIndex pattern@(DottedList _ _) input@(DottedList _ _) flags =- loadLocal outerEnv localEnv identifiers pattern input ellipsisLevel ellipsisIndex flags+checkLocal defEnv outerEnv localEnv renameEnv identifiers ellipsisLevel ellipsisIndex pattern@(DottedList _ _) input@(DottedList _ _) flags =+ loadLocal defEnv outerEnv localEnv renameEnv identifiers pattern input ellipsisLevel ellipsisIndex flags -checkLocal outerEnv localEnv identifiers ellipsisLevel ellipsisIndex (DottedList ps p) input@(List (_ : _)) flags = do- loadLocal outerEnv localEnv identifiers +checkLocal defEnv outerEnv localEnv renameEnv identifiers ellipsisLevel ellipsisIndex (DottedList ps p) input@(List (_ : _)) flags = do+ loadLocal defEnv outerEnv localEnv renameEnv identifiers (List $ ps ++ [p, Atom "..."]) input ellipsisLevel -- Incremented in the list/list match below ellipsisIndex (flagDottedLists flags (True, False) $ length ellipsisIndex)-checkLocal outerEnv localEnv identifiers ellipsisLevel ellipsisIndex pattern@(List _) input@(List _) flags =- loadLocal outerEnv localEnv identifiers pattern input ellipsisLevel ellipsisIndex flags+checkLocal defEnv outerEnv localEnv renameEnv identifiers ellipsisLevel ellipsisIndex pattern@(List _) input@(List _) flags =+ loadLocal defEnv outerEnv localEnv renameEnv identifiers pattern input ellipsisLevel ellipsisIndex flags -checkLocal _ _ _ _ _ _ _ _ = return $ Bool False+checkLocal _ _ _ _ _ _ _ _ _ _ = return $ Bool False +-- |Determine if an identifier in a pattern matches an identifier of the same+-- name in the input.+--+-- Note that identifiers are lexically scoped: bindings that intervene+-- between the definition and use of a macro may cause match failure+--+-- TODO: what if var is a macro or a special form?+--+-- TODO: what about vars that are introduced during macro expansion, that are not+-- yet defined in an Env? This may be a future TBD+--+identifierMatches :: Env -> Env -> String -> IOThrowsError Bool+identifierMatches defEnv useEnv ident = do+ atDef <- liftIO $ isRecBound defEnv ident+ atUse <- liftIO $ isRecBound useEnv ident+ matchIdent atDef atUse++ where+ matchIdent False False = return True -- Never defined, so match+ matchIdent True True = do -- Defined in both places, check for equality+ d <- getVar defEnv ident+ u <- getVar useEnv ident+ return $ eqVal d u + matchIdent _ _ = return False -- Not defined in one place, reject it ++-- |Walk expanded code per Clinger+walkExpanded :: Env -> Env -> Env -> Env -> Bool -> Bool -> LispVal -> LispVal -> IOThrowsError LispVal+walkExpanded defEnv useEnv renameEnv cleanupEnv _ isQuoted (List result) (List (List l : ls)) = do+ lst <- walkExpanded defEnv useEnv renameEnv cleanupEnv True isQuoted (List []) (List l)+ walkExpanded defEnv useEnv renameEnv cleanupEnv False isQuoted (List $ result ++ [lst]) (List ls)++walkExpanded defEnv useEnv renameEnv cleanupEnv _ isQuoted (List result) (List ((Vector v) : vs)) = do+ List lst <- walkExpanded defEnv useEnv renameEnv cleanupEnv False isQuoted (List []) (List $ elems v)+ walkExpanded defEnv useEnv renameEnv cleanupEnv False isQuoted (List $ result ++ [asVector lst]) (List vs)++walkExpanded defEnv useEnv renameEnv cleanupEnv _ isQuoted (List result) (List ((DottedList ds d) : ts)) = do+ List ls <- walkExpanded defEnv useEnv renameEnv cleanupEnv False isQuoted (List []) (List ds)+ l <- walkExpanded defEnv useEnv renameEnv cleanupEnv False isQuoted (List []) d+ walkExpanded defEnv useEnv renameEnv cleanupEnv False isQuoted (List $ result ++ [DottedList ls l]) (List ts)++walkExpanded defEnv useEnv renameEnv cleanupEnv startOfList inputIsQuoted (List result) transform@(List (Atom aa : ts)) = do+ + Atom a <- expandAtom renameEnv (Atom aa)++ -- If a macro is quoted, keep track of it and do not invoke rules below for+ -- procedure abstraction or macro calls + let isQuoted = inputIsQuoted || (a == "quote") || (a == "quasiquote")+ let isQuasiQuoted = (a == "quasiquote")++ isDefinedAsMacro <- liftIO $ isNamespacedRecBound useEnv macroNamespace a+ if (startOfList) && a == "define-syntax" && not isQuoted+ then case ts of+ [Atom keyword, (List (Atom "syntax-rules" : (List identifiers : rules)))] -> do+ -- Do we need to rename the keyword, or at least take that into account?+ _ <- defineNamespacedVar useEnv macroNamespace keyword $ Syntax useEnv identifiers rules+ return $ Nil "" -- Sentinal value+ _ -> throwError $ BadSpecialForm "Malformed define-syntax expression" transform+ else if startOfList && a == "lambda" && not isQuoted -- Placed here, the lambda primitive trumps a macro of the same name... (desired behavior?)+ then do+ case transform of+ List (Atom _ : List vars : fbody) -> do+ -- Create a new Env for this, so args of the same name do not overwrite those in the current Env+ env <- liftIO $ extendEnv renameEnv []+ renamedVars <- markBoundIdentifiers env cleanupEnv vars []+ walkExpanded defEnv useEnv env cleanupEnv False isQuoted (List [Atom "lambda", renamedVars]) (List fbody)+ -- lambda is malformed, just transform as normal atom...+ _ -> walkExpanded defEnv useEnv renameEnv cleanupEnv False isQuoted (List $ result ++ [Atom a]) (List ts)+ else if startOfList && isDefinedAsMacro && not isQuoted+ then do+ Syntax _ identifiers rules <- getNamespacedVar useEnv macroNamespace a+ -- A child renameEnv is not created because for a macro call there is no way an+ -- renamed identifier inserted by the macro could override one in the outer env.+ --+ -- This is because the macro renames non-matched identifiers and stores mappings+ -- from the {rename ==> original}. Each new name is unique by definition, so+ -- no conflicts are possible.+ macroTransform defEnv useEnv renameEnv cleanupEnv (List identifiers) rules (List (Atom a : ts))+ else if isQuoted+ then do+ -- Cleanup all symbols in the quoted code+ List cleaned <- cleanExpanded + defEnv useEnv renameEnv cleanupEnv + True isQuasiQuoted + (List []) (List ts)+ return $ List $ result ++ (Atom a : cleaned)+ else walkExpanded defEnv useEnv renameEnv cleanupEnv + False isQuoted + (List $ result ++ [Atom a]) (List ts)++-- Transform anything else as itself...+walkExpanded defEnv useEnv renameEnv cleanupEnv _ isQuoted (List result) (List (t : ts)) = do+ walkExpanded defEnv useEnv renameEnv cleanupEnv False isQuoted (List $ result ++ [t]) (List ts)++-- Base case - empty transform+walkExpanded _ _ _ _ _ _ result@(List _) (List []) = return result++-- Single atom, rename (if necessary) and return+walkExpanded _ _ renameEnv _ _ _ _ (Atom a) = expandAtom renameEnv (Atom a)++-- 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.+walkExpanded _ _ _ _ _ _ _ transform = return transform++-- |Accept a list of bound identifiers from a lambda expression, and rename them+-- Returns a list of the renamed identifiers as well as marking those identifiers+-- in the given environment, so they can be renamed during expansion.+markBoundIdentifiers :: Env -> Env -> [LispVal] -> [LispVal] -> IOThrowsError LispVal+markBoundIdentifiers env cleanupEnv (Atom v : vs) renamedVars = do+ Atom renamed <- _gensym v+ _ <- defineVar env v $ Atom renamed+ _ <- defineVar cleanupEnv renamed $ Atom v+ markBoundIdentifiers env cleanupEnv vs $ renamedVars ++ [Atom renamed]+markBoundIdentifiers env cleanupEnv (_: vs) renamedVars = markBoundIdentifiers env cleanupEnv vs renamedVars+markBoundIdentifiers _ _ [] renamedVars = return $ List renamedVars++-- |Recursively expand an atom that may have been renamed multiple times+expandAtom :: Env -> LispVal -> IOThrowsError LispVal+expandAtom renameEnv (Atom a) = do+ isDefined <- liftIO $ isRecBound renameEnv a -- Search parent Env's also+ if isDefined + then do+ expanded <- getVar renameEnv a+ return expanded -- disabled this; just expand once. expandAtom renameEnv expanded -- Recursively expand+ else return $ Atom a +expandAtom _ a = return a++-- |Clean up any remaining renamed variables in the expanded code+-- Only needed in special circumstances to deal with quoting.+--+-- Notes:+--+-- Keep in mind this will never work when using the renameEnv from walk, because that env binds+-- (old name => new name) in order to clean up any new names prior to eval, there would+-- need to be another environment with the reverse mappings.+--+-- ALSO, due to parent Env logic going on, these bindings need to be in some sort of+-- 'master' env that transcends those env's and maps all gensyms back to their original symbols+--+cleanExpanded :: Env -> Env -> Env -> Env -> Bool -> Bool -> LispVal -> LispVal -> IOThrowsError LispVal++cleanExpanded defEnv useEnv renameEnv cleanupEnv _ isQQ (List result) (List (List l : ls)) = do+ lst <- cleanExpanded defEnv useEnv renameEnv cleanupEnv True isQQ (List []) (List l)+ cleanExpanded defEnv useEnv renameEnv cleanupEnv False isQQ (List $ result ++ [lst]) (List ls)++cleanExpanded defEnv useEnv renameEnv cleanupEnv _ isQQ (List result) (List ((Vector v) : vs)) = do+ List lst <- cleanExpanded defEnv useEnv renameEnv cleanupEnv True isQQ (List []) (List $ elems v)+ cleanExpanded defEnv useEnv renameEnv cleanupEnv False isQQ (List $ result ++ [asVector lst]) (List vs)++cleanExpanded defEnv useEnv renameEnv cleanupEnv _ isQQ (List result) (List ((DottedList ds d) : ts)) = do+ List ls <- cleanExpanded defEnv useEnv renameEnv cleanupEnv True isQQ (List []) (List ds)+ l <- cleanExpanded defEnv useEnv renameEnv cleanupEnv True isQQ (List []) d+ cleanExpanded defEnv useEnv renameEnv cleanupEnv False isQQ (List $ result ++ [DottedList ls l]) (List ts)++cleanExpanded defEnv useEnv renameEnv cleanupEnv startOfList isQQ (List result) (List (Atom a : ts)) = do+ expanded <- tmpexpandAtom cleanupEnv $ Atom a+ case (startOfList, isQQ, expanded) of+ -- Unquote an expression by continuing to expand it as a macro form+ -- + -- Only perform an unquote if (in order):+ -- - We are currently at the head of the list+ -- - Expression is quasi-quoted+ -- - An "unquote" is found+ --+ (True, True, Atom "unquote") -> do + r <- walkExpanded defEnv useEnv renameEnv cleanupEnv True False (List $ result ++ [Atom "unquote"]) (List ts)+ return r+ _ -> + cleanExpanded defEnv useEnv renameEnv cleanupEnv False isQQ (List $ result ++ [expanded]) (List ts)+ where+ -- TODO: figure out a way to simplify this code (perhaps consolidate with expandAtom)+ tmpexpandAtom :: Env -> LispVal -> IOThrowsError LispVal+ tmpexpandAtom _renameEnv (Atom _a) = do+ isDefined <- liftIO $ isRecBound _renameEnv _a -- Search parent Env's also+ if isDefined + then do+ expanded <- getVar _renameEnv _a+ tmpexpandAtom _renameEnv expanded -- Recursively expand+ else return $ Atom _a + tmpexpandAtom _ _a = return _a++-- Transform anything else as itself...+cleanExpanded defEnv useEnv renameEnv cleanupEnv _ isQQ (List result) (List (t : ts)) = do+ cleanExpanded defEnv useEnv renameEnv cleanupEnv False isQQ (List $ result ++ [t]) (List ts)++-- Base case - empty transform+cleanExpanded _ _ _ _ _ _ result@(List _) (List []) = do+ return result++-- 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.+cleanExpanded _ _ _ _ _ _ _ transform = return transform++ {- |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 -- ^ Outer, enclosing environment- -> Env -- ^ Environment local to the macro+ with the same form, replacing identifiers in the tranform with those bound in localEnv ++ This is essentially the rewrite step from MTW, and does all that is req'd, including:+ - renaming of free variables+ - collecting an env of variables that are renamed+ - diverting bindings back into the Env of use (outer env)+-}+transformRule :: Env -- ^ Environment the macro was defined in+ -> Env -- ^ Outer, enclosing environment+ -> Env -- ^ Environment local to the macro containing pattern variables+ -> Env -- ^ Environment local to the macro containing renamed variables+ -> Env -- ^ Environment local to the macro used to cleanup any left-over renamed vars + -> LispVal -- ^ Literal identifiers -> Int -- ^ ellipsisLevel - Nesting level of the zero-to-many match, or 0 if none -> [Int] -- ^ ellipsisIndex - The index at each ellipsisLevel. This is used to read data stored in -- pattern variables.@@ -507,57 +730,55 @@ -> IOThrowsError LispVal -- Recursively transform a list-transformRule outerEnv localEnv ellipsisLevel ellipsisIndex (List result) transform@(List (List l : ts)) = do+transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex (List result) transform@(List (List l : ts)) = do let nextHasEllipsis = macroElementMatchesMany transform let level = calcEllipsisLevel nextHasEllipsis ellipsisLevel let idx = calcEllipsisIndex nextHasEllipsis level ellipsisIndex if (nextHasEllipsis) then do- curT <- transformRule outerEnv localEnv level idx (List []) (List l)+ curT <- transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers level idx (List []) (List l) case (curT) of Nil _ -> -- No match ("zero" case). Use tail to move past the "..."- continueTransform outerEnv localEnv ellipsisLevel ellipsisIndex result $ tail ts- List _ -> transformRule outerEnv localEnv + continueTransform defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex result $ tail ts+ List _ -> transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel -- Do not increment level, just wait until the next go-round when it will be incremented above idx -- Must keep index since it is incremented each time (List $ result ++ [curT]) transform _ -> throwError $ Default "Unexpected error" else do- lst <- transformRule outerEnv localEnv ellipsisLevel ellipsisIndex (List []) (List l)+ lst <- transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex (List []) (List l) case lst of- List _ -> transformRule outerEnv localEnv ellipsisLevel ellipsisIndex (List $ result ++ [lst]) (List ts)+ List _ -> transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex (List $ result ++ [lst]) (List ts) Nil _ -> return lst _ -> throwError $ BadSpecialForm "Macro transform error" $ List [lst, (List l), Number $ toInteger ellipsisLevel] -- Recursively transform a vector by processing it as a list -- FUTURE: can this code be consolidated with the list code?-transformRule outerEnv localEnv ellipsisLevel ellipsisIndex (List result) transform@(List ((Vector v) : ts)) = do+transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex (List result) transform@(List ((Vector v) : ts)) = do let nextHasEllipsis = macroElementMatchesMany transform let level = calcEllipsisLevel nextHasEllipsis ellipsisLevel let idx = calcEllipsisIndex nextHasEllipsis level ellipsisIndex if nextHasEllipsis then do -- Idea here is that we need to handle case where you have (vector ...) - EG: (#(var step) ...)- curT <- transformRule outerEnv localEnv level idx (List []) (List $ elems v)+ curT <- transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers level idx (List []) (List $ elems v) -- case (trace ("curT = " ++ show curT) curT) of case curT of Nil _ -> -- No match ("zero" case). Use tail to move past the "..."- continueTransform outerEnv localEnv ellipsisLevel ellipsisIndex result $ tail ts- List t -> transformRule outerEnv localEnv + continueTransform defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex result $ tail ts+ List t -> transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel -- Do not increment level, just wait until the next go-round when it will be incremented above idx -- Must keep index since it is incremented each time (List $ result ++ [asVector t]) transform _ -> throwError $ Default "Unexpected error in transformRule"- else do lst <- transformRule outerEnv localEnv ellipsisLevel ellipsisIndex (List []) (List $ elems v)+ else do lst <- transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex (List []) (List $ elems v) case lst of- List l -> transformRule outerEnv localEnv ellipsisLevel ellipsisIndex (List $ result ++ [asVector l]) (List ts)+ List l -> transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex (List $ result ++ [asVector l]) (List ts) Nil _ -> return lst _ -> throwError $ BadSpecialForm "transformRule: Macro transform error" $ List [lst, (List [Vector v]), Number $ toInteger ellipsisLevel] - where asVector lst = (Vector $ (listArray (0, length lst - 1)) lst)- -- Recursively transform an improper list-transformRule outerEnv localEnv ellipsisLevel ellipsisIndex (List result) transform@(List (dl@(DottedList _ _) : ts)) = do+transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex (List result) transform@(List (dl@(DottedList _ _) : ts)) = do let nextHasEllipsis = macroElementMatchesMany transform let level = calcEllipsisLevel nextHasEllipsis ellipsisLevel let idx = calcEllipsisIndex nextHasEllipsis level ellipsisIndex@@ -565,29 +786,56 @@ -- if (trace ("trans Pair: " ++ show transform ++ " lvl = " ++ show ellipsisLevel ++ " idx = " ++ show ellipsisIndex) nextHasEllipsis) then do -- Idea here is that we need to handle case where you have (pair ...) - EG: ((var . step) ...)- curT <- transformDottedList outerEnv localEnv level idx (List []) (List [dl])+ curT <- transformDottedList defEnv outerEnv localEnv renameEnv cleanupEnv identifiers level idx (List []) (List [dl]) case curT of Nil _ -> -- No match ("zero" case). Use tail to move past the "..."- continueTransform outerEnv localEnv ellipsisLevel ellipsisIndex result $ tail ts - List t -> transformRule outerEnv localEnv + continueTransform defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex result $ tail ts + List t -> transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel -- Do not increment level, just wait until next iteration where incremented above idx -- Keep incrementing each time (List $ result ++ t) transform _ -> throwError $ Default "Unexpected error in transformRule"- else do lst <- transformDottedList outerEnv localEnv ellipsisLevel ellipsisIndex (List []) (List [dl])+ else do lst <- transformDottedList defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex (List []) (List [dl]) case lst of- List l -> transformRule outerEnv localEnv ellipsisLevel ellipsisIndex (List $ result ++ l) (List ts)+ List l -> transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex (List $ result ++ l) (List ts) Nil _ -> return lst _ -> throwError $ BadSpecialForm "transformRule: Macro transform error" $ List [lst, (List [dl]), Number $ toInteger ellipsisLevel] --- Transform an atom by attempting to look it up as a var...-transformRule outerEnv localEnv ellipsisLevel ellipsisIndex (List result) transform@(List (Atom a : ts)) = do- isDefined <- liftIO $ isBound localEnv a- if hasEllipsis- then ellipsisHere isDefined- else noEllipsis isDefined+-- |Transform an atom+--+-- This is a complicated transformation because we need to take into account+-- literal identifiers, pattern variables, ellipses in the current list, and +-- nested ellipses.+transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex (List result) transform@(List (Atom a : ts)) = do+ Bool isIdent <- findAtom (Atom a) identifiers -- Literal Identifier+ isDefined <- liftIO $ isBound localEnv a -- Pattern Variable + if isIdent+ then literalHere+ else do+ if hasEllipsis+ then ellipsisHere isDefined+ else noEllipsis isDefined+ where+ literalHere = do+ expanded <- transformLiteralIdentifier defEnv outerEnv localEnv a+ if hasEllipsis + then do+ -- Skip over ellipsis if present+ -- + -- TODO:+ -- We should throw an error here, but the problem is that we need to differentiate+ -- between the case where an ellipsis is inserted as a shorthand for a pair (in which+ -- case this is allowed) or when an ellipsis is present in the actual macro (which+ -- should be an error).+ --+ transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex (List $ result ++ [expanded]) (List $ tail ts)+ -- TODO: if error (per above logic) then -+ -- throwError $ Default "Unexpected ellipsis encountered after literal identifier in macro template" + else do+ continueTransformWith $ result ++ [expanded]+ -- A function to use input flags to append a '() to a list if necessary -- Only makes sense to do this if the *transform* is a dotted list appendNil d (Bool isImproperPattern) (Bool isImproperInput) =@@ -615,31 +863,22 @@ case var of -- add all elements of the list into result List _ -> do case (appendNil (Matches.getData var ellipsisIndex) isImproperPattern isImproperInput) of- List aa -> transformRule outerEnv localEnv ellipsisLevel ellipsisIndex (List $ result ++ aa) (List $ tail ts)+ List aa -> transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex (List $ result ++ aa) (List $ tail ts) _ -> -- No matches for var- continueTransform outerEnv localEnv ellipsisLevel ellipsisIndex result $ tail ts+ continueTransform defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex result $ tail ts -{- TODO: Nil input -> do -- Var lexically defined outside of macro, load from there------ notes: 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 -} Nil "" -> -- No matches, keep going- continueTransform outerEnv localEnv ellipsisLevel ellipsisIndex result $ tail ts- v@(_) -> transformRule outerEnv localEnv ellipsisLevel ellipsisIndex (List $ result ++ [v]) (List $ tail ts)+ continueTransform defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex result $ tail ts+ v@(_) -> transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex (List $ result ++ [v]) (List $ tail ts) else -- Matched 0 times, skip it- transformRule outerEnv localEnv ellipsisLevel ellipsisIndex (List result) (List $ tail ts)+ transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex (List result) (List $ tail ts) noEllipsis isDefined = do isImproperPattern <- loadNamespacedBool "improper pattern" isImproperInput <- loadNamespacedBool "improper input"--- t <- if (trace ("a = " ++ show a ++ "isDefined = " ++ show isDefined) isDefined) t <- if (isDefined) then do var <- getVar localEnv a--- case (trace ("var = " ++ show var) var) of case (var) of Nil "" -> do -- Fix for issue #42: A 0 match case for var (input ran out in pattern), flag to calling code@@ -651,6 +890,7 @@ case wasPair of Bool True -> return $ Nil "var (pair) not defined in pattern" _ -> return $ Nil "var not defined in pattern"+-- TODO: I think the outerEnv should be accessed by the walker, and not within rewrite as is done below... Nil input -> do v <- getVar outerEnv input return v List v -> do@@ -666,7 +906,23 @@ then -- List req'd for 0-or-n match throwError $ Default "Unexpected error processing data in transformRule" else return var- else return $ Atom a+ else do+ -- Rename each encountered symbol, but the trick is that we want to give+ -- the same symbol the same new name if it is found more than once, so...+ -- we need to keep track of the var in two environments to map both ways + -- between the original name and the new name.+ isAlreadyRenamed <- liftIO $ isNamespacedBound localEnv "renamed" a+ if isAlreadyRenamed+ then do+ renamed <- getNamespacedVar localEnv "renamed" a+ return renamed+ else do+ Atom renamed <- _gensym a+ _ <- defineNamespacedVar localEnv "renamed" a $ Atom renamed+ -- Keep track of vars that are renamed; maintain reverse mapping+ _ <- defineVar cleanupEnv renamed $ Atom a -- Global record for final cleanup of macro+ _ <- defineVar (renameEnv) renamed $ Atom a -- Keep for Clinger+ return $ Atom renamed case t of Nil "var not defined in pattern" -> if ellipsisLevel > 0@@ -693,34 +949,79 @@ -- Continue calling into transformRule continueTransformWith results = - transformRule outerEnv - localEnv + transformRule defEnv outerEnv + localEnv+ renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex (List $ results) (List ts) -- Transform anything else as itself...-transformRule outerEnv localEnv ellipsisLevel ellipsisIndex (List result) (List (t : ts)) = do- transformRule outerEnv localEnv ellipsisLevel ellipsisIndex (List $ result ++ [t]) (List ts) +transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex (List result) (List (t : ts)) = do+ transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex (List $ result ++ [t]) (List ts) -- Base case - empty transform-transformRule _ _ _ _ result@(List _) (List []) = do+transformRule _ _ _ _ _ _ _ _ result@(List _) (List []) = do return result --- Transform is a single var, just look it up.-transformRule _ localEnv _ _ _ (Atom transform) = do- v <- getVar localEnv transform- return v+-- Transform a single var+--+-- The nice thing about this case is that the only way we can get here is if the+-- transform is an atom - if it is a list then there is no way this case can be reached.+-- So... we do not need to worry about pattern variables here. No need to port that code+-- from the above case.+transformRule defEnv outerEnv localEnv _ _ identifiers _ _ _ (Atom transform) = do+ Bool isIdent <- findAtom (Atom transform) identifiers+ isPattVar <- liftIO $ isRecBound localEnv transform+ if isPattVar && not isIdent+ then getVar localEnv transform+ else transformLiteralIdentifier defEnv outerEnv localEnv transform -- 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 = return transform+transformRule _ _ _ _ _ _ _ _ _ transform = return transform +-- |A helper function for transforming an atom that has been marked as as literal identifier+transformLiteralIdentifier :: Env -> Env -> Env -> String -> IOThrowsError LispVal+transformLiteralIdentifier defEnv outerEnv _ transform = do+ isInDef <- liftIO $ isRecBound defEnv transform+ if isInDef+ then do+ {- Variable exists in the environment the macro was defined in,+ so divert that value back into the environment of use. The value+ is diverted back with a different name so as not to be shadowed by+ a variable of the same name in env of use. -}+ value <- getVar defEnv transform+ Atom renamed <- _gensym transform+ _ <- defineVar outerEnv renamed value + return $ Atom renamed+ else do+{- TODO: +else if not defined in defEnv then just pass the var back as-is (?)+ this is not entirely correct, a special form would not be defined but still has+ a meaning and could be shadowed in useEnv. need some way of being able to+ divert a special form back into useEnv...++Or, consider the following example. csi throws an error because if is not defined.+If we make the modifications to store intermediate vars somewhere that are introduced+via lambda, set!, and define then we may be able to throw an error if the var is not+defined, instead of trying to store the special form to a variable somehow.++;(define if 3)+(define-syntax test-template+ (syntax-rules (if)+ ((_)+ if)))+(write (let ((if 1)) (test-template)) )+(write (let ((if 2)) (test-template)) )+-}+ return $ Atom transform+ -- | A helper function for transforming an improper list-transformDottedList :: Env -> Env -> Int -> [Int] -> LispVal -> LispVal -> IOThrowsError LispVal-transformDottedList outerEnv localEnv ellipsisLevel ellipsisIndex (List result) (List (DottedList ds d : ts)) = do- lsto <- transformRule outerEnv localEnv ellipsisLevel ellipsisIndex (List []) (List ds)+transformDottedList :: Env -> Env -> Env -> Env -> Env -> LispVal -> Int -> [Int] -> LispVal -> LispVal -> IOThrowsError LispVal+transformDottedList defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex (List result) (List (DottedList ds d : ts)) = do+ lsto <- transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex (List []) (List ds) case lsto of List lst -> do -- Similar logic to the parser is applied here, where@@ -728,7 +1029,7 @@ -- they form a proper list -- -- d is an n-ary match, per Issue #34- r <- transformRule outerEnv localEnv + r <- transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel -- OK not to increment here, this is accounted for later on ellipsisIndex -- Same as above (List []) @@ -736,11 +1037,11 @@ case r of -- Trailing symbol in the pattern may be neglected in the transform, so skip it... List [] ->- transformRule outerEnv localEnv ellipsisLevel ellipsisIndex (List $ result ++ [List lst]) (List ts)+ transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex (List $ result ++ [List lst]) (List ts) Nil _ -> -- Same as above, no match for d, so skip it - transformRule outerEnv localEnv ellipsisLevel ellipsisIndex (List $ result ++ [List lst]) (List ts)+ transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex (List $ result ++ [List lst]) (List ts) List rst -> do- transformRule outerEnv localEnv ellipsisLevel ellipsisIndex + transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex (buildTransformedCode result lst rst) (List ts) _ -> throwError $ BadSpecialForm "Macro transform error processing pair" $ DottedList ds d Nil _ -> return $ Nil ""@@ -751,6 +1052,7 @@ buildTransformedCode results ps p = do case p of [List []] -> List $ results ++ [List ps] -- Proper list has null list at the end+ [List l@(Atom "unquote" : _ )] -> List $ results ++ [DottedList ps $ List l] -- Special case from parser. [List ls] -> List $ results ++ [List $ ps ++ ls] -- Again, convert to proper list because a proper list is at end [l] -> List $ results ++ [DottedList ps l] ls -> do@@ -762,14 +1064,16 @@ t -> List $ results ++ [DottedList (ps ++ init ls) t] -transformDottedList _ _ _ _ _ _ = throwError $ Default "Unexpected error in transformDottedList"+transformDottedList _ _ _ _ _ _ _ _ _ _ = throwError $ Default "Unexpected error in transformDottedList" -- |Continue transforming after a preceding match has ended -continueTransform :: Env -> Env -> Int -> [Int] -> [LispVal] -> [LispVal] -> IOThrowsError LispVal-continueTransform outerEnv localEnv ellipsisLevel ellipsisIndex result remaining = do+continueTransform :: Env -> Env -> Env -> Env -> Env -> LispVal -> Int -> [Int] -> [LispVal] -> [LispVal] -> IOThrowsError LispVal+continueTransform defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex result remaining = do if not (null remaining)- then transformRule outerEnv + then transformRule defEnv outerEnv localEnv + renameEnv+ cleanupEnv identifiers ellipsisLevel ellipsisIndex (List result) @@ -807,3 +1111,8 @@ -- First input element that matches pattern; start at 0 else ellipsisIndex ++ [0] else ellipsisIndex++-- |Convert a list of lisp values to a vector+asVector :: [LispVal] -> LispVal+asVector lst = (Vector $ (listArray (0, length lst - 1)) lst)+
hs-src/Language/Scheme/Types.hs view
@@ -151,6 +151,19 @@ , dynamicWind :: (Maybe [DynamicWinders]) -- Functions injected by (dynamic-wind) } -- ^Continuation+ | Syntax { synClosure :: Env+ , synIdentifiers :: [LispVal]+ , synRules :: [LispVal]+-- , synPattern :: [LispVal]+-- , synTemplate :: [LispVal] -- TODO: use a syntax-rules type to hold a single pattern/transform pair?++ } -- ^ Type to hold a syntax object that is created by a macro definition.+ -- Syntax objects are not used like regular types in that they are not+ -- passed around within variables. In other words, you cannot use set! to+ -- assign a variable to a syntax object. But they are used during function+ -- application. In any case, it is convenient to define the type here + -- because syntax objects are stored in the same environments and + -- manipulated by the same functions as regular variables. | EOF | Nil String -- ^Internal use only; do not use this type directly.@@ -262,6 +275,7 @@ showVal (DottedList h t) = "(" ++ unwordsList h ++ " . " ++ showVal t ++ ")" showVal (PrimitiveFunc _) = "<primitive>" showVal (Continuation _ _ _ _ _) = "<continuation>"+showVal (Syntax _ _ _) = "<syntax>" showVal (Func {params = args, vararg = varargs, body = _, closure = _}) = "(lambda (" ++ unwords (map show args) ++ (case varargs of
hs-src/Language/Scheme/Variables.hs view
@@ -20,6 +20,45 @@ import Control.Monad.Error import Data.IORef +{- Experimental code:+-- From: http://rafaelbarreto.com/2011/08/21/comparing-objects-by-memory-location-in-haskell/+import Foreign+isMemoryEquivalent :: a -> a -> IO Bool+isMemoryEquivalent obj1 obj2 = do+ obj1Ptr <- newStablePtr obj1+ obj2Ptr <- newStablePtr obj2+ let result = obj1Ptr == obj2Ptr+ freeStablePtr obj1Ptr+ freeStablePtr obj2Ptr+ return result++-- Using above, search an env for a variable definition, but stop if the upperEnv is+-- reached before the variable+isNamespacedRecBoundWUpper :: Env -> Env -> String -> String -> IO Bool+isNamespacedRecBoundWUpper upperEnvRef envRef namespace var = do + areEnvsEqual <- liftIO $ isMemoryEquivalent upperEnvRef envRef+ if areEnvsEqual+ then return False+ else do+ found <- liftIO $ isNamespacedBound envRef namespace var+ if found+ then return True + else case parentEnv envRef of+ (Just par) -> isNamespacedRecBoundWUpper upperEnvRef par namespace var+ Nothing -> return False -- Var never found+-}++-- |Create a deep copy of an environment+copyEnv :: Env -> IO Env+copyEnv env = do+ binds <- liftIO $ readIORef $ bindings env+ bindingList <- mapM addBinding binds >>= newIORef+ return $ Environment (parentEnv env) bindingList -- TODO: recursively create a copy of parent also?+ where addBinding ((namespace, name), val) = do --ref <- newIORef $ liftIO $ readIORef val+ x <- liftIO $ readIORef val+ ref <- newIORef x+ return ((namespace, name), ref)+ -- |Extend given environment by binding a series of values to a new environment. extendEnv :: Env -> [((String, String), LispVal)] -> IO Env extendEnv envRef abindings = do bindinglist <- mapM addBinding abindings >>= newIORef@@ -40,6 +79,10 @@ -- |Determine if a variable is bound in the default namespace isBound :: Env -> String -> IO Bool isBound envRef var = isNamespacedBound envRef varNamespace var++-- |Determine if a variable is bound in the default namespace, in this env or a parent+isRecBound :: Env -> String -> IO Bool+isRecBound envRef var = isNamespacedRecBound envRef varNamespace var -- |Determine if a variable is bound in a given namespace isNamespacedBound :: Env -> String -> String -> IO Bool
hs-src/shell.hs view
@@ -67,7 +67,7 @@ putStrLn " | | | | |_| \\__ \\ < /// \\\\\\ \\__ \\ (__| | | | __/ | | | | | __/ " putStrLn " |_| |_|\\__,_|___/_|\\_\\ /// \\\\\\ |___/\\___|_| |_|\\___|_| |_| |_|\\___| " putStrLn " "- putStrLn " husk Scheme Interpreter Version 3.3 "+ putStrLn " husk Scheme Interpreter Version 3.4 " 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.3+Version: 3.4 Synopsis: R5RS Scheme interpreter program and library. Description: A dialect of R5RS Scheme written in Haskell. Provides advanced - features including continuations, non-hygienic macros, a Haskell FFI,+ features including continuations, hygienic macros, a Haskell FFI, and the full numeric tower. License: MIT License-file: LICENSE@@ -19,7 +19,7 @@ Data-Files: stdlib.scm Library- Build-Depends: base >= 2.0 && < 5, array, containers, haskeline, haskell98 < 2, mtl, parsec, directory, ghc, ghc-paths+ Build-Depends: base >= 2.0 && < 5, array, containers, haskeline, haskell98, mtl, parsec, directory, ghc, ghc-paths Extensions: ExistentialQuantification CPP CPP Hs-Source-Dirs: hs-src Exposed-Modules: Language.Scheme.Core@@ -34,7 +34,7 @@ Language.Scheme.Primitives Executable huski- Build-Depends: base >= 2.0 && < 5, array, containers, haskeline, haskell98 < 2, mtl, parsec, directory, ghc, ghc-paths+ Build-Depends: base >= 2.0 && < 5, array, containers, haskeline, haskell98, mtl, parsec, directory, ghc, ghc-paths Extensions: ExistentialQuantification CPP CPP Main-is: shell.hs Hs-Source-Dirs: hs-src
stdlib.scm view
@@ -233,13 +233,13 @@ ; (define-syntax let* (syntax-rules ()- ((_ () body) ((lambda () body)))- ((_ ((var val)- (vars vals) ...)- body)- (let ((var val))- (let* ((vars vals) ...)- body)))))+ ((let* () body1 body2 ...)+ (let () body1 body2 ...))+ ((let* ((name1 val1) (name2 val2) ...)+ body1 body2 ...)+ (let ((name1 val1))+ (let* ((name2 val2) ...)+ body1 body2 ...))))) ; Iteration - do (define-syntax do