husk-scheme 3.4.1 → 3.4.2
raw patch · 6 files changed
+344/−197 lines, 6 files
Files
- README.markdown +1/−1
- hs-src/Language/Scheme/Core.hs +16/−15
- hs-src/Language/Scheme/Macro.hs +318/−172
- hs-src/Language/Scheme/Types.hs +7/−7
- hs-src/shell.hs +1/−1
- husk-scheme.cabal +1/−1
README.markdown view
@@ -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 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.+- Hygienic Macros: High-level macros via define-syntax, let-syntax, and letrec-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 almost all derived forms are implemented as macros 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
@@ -22,7 +22,7 @@ , primitiveBindings ) where import qualified Language.Scheme.FFI-import Language.Scheme.Macro+import qualified Language.Scheme.Macro import Language.Scheme.Numerical import Language.Scheme.Parser import Language.Scheme.Primitives@@ -68,7 +68,7 @@ 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) + Language.Scheme.Macro.macroEval env lisp >>= (func env cont) {- OBSOLETE: old code for updating env's in the continuation chain (see below) if False --needToExtendEnv lisp@@ -274,18 +274,15 @@ cpsUnquoteFld _ _ _ _ = throwError $ InternalError "Unexpected parameters to cpsUnquoteFld" -- A rudimentary implementation of let-syntax-eval env cont args@(List (Atom "let-syntax" : List bindings : body)) = do+eval env cont (List (Atom "let-syntax" : List bindings : body)) = do -- TODO: check if let-syntax has been rebound?------ 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--- bodyEnv <- liftIO $ extendEnv env []- _ <- loadMacros env bodyEnv bindings- continueEval bodyEnv (Continuation bodyEnv (Just $ SchemeBody body) (Just cont) Nothing Nothing) $ Nil "" + _ <- Language.Scheme.Macro.loadMacros env bodyEnv Nothing False bindings+ -- Expand whole body as a single continuous macro, to ensure hygiene+ expanded <- Language.Scheme.Macro.expand bodyEnv False $ List body + case expanded of+ List e -> continueEval bodyEnv (Continuation bodyEnv (Just $ SchemeBody e) (Just cont) Nothing Nothing) $ Nil "" + e -> continueEval bodyEnv cont e eval env cont args@(List (Atom "letrec-syntax" : List bindings : body)) = do -- TODO: check if letrec-syntax has been rebound?@@ -294,8 +291,12 @@ -- the letrec's environment, instead of the parent env. Not sure if this is 100% correct but it -- is good enough to pass the R5RS test case so it will be used as a rudimentary implementation -- for now...- _ <- loadMacros bodyEnv bodyEnv bindings- continueEval bodyEnv (Continuation bodyEnv (Just $ SchemeBody body) (Just cont) Nothing Nothing) $ Nil "" + _ <- Language.Scheme.Macro.loadMacros bodyEnv bodyEnv Nothing False bindings+ -- Expand whole body as a single continuous macro, to ensure hygiene+ expanded <- Language.Scheme.Macro.expand bodyEnv False $ List body + case expanded of+ List e -> continueEval bodyEnv (Continuation bodyEnv (Just $ SchemeBody e) (Just cont) Nothing Nothing) $ Nil "" + e -> continueEval bodyEnv cont e eval env cont args@(List [Atom "define-syntax", Atom keyword, (List (Atom "syntax-rules" : (List identifiers : rules)))]) = do bound <- liftIO $ isRecBound env "define-syntax"@@ -319,7 +320,7 @@ -- Anyway, this may come back. But not using it for now... -- -- defEnv <- liftIO $ copyEnv env- _ <- defineNamespacedVar env macroNamespace keyword $ Syntax env identifiers rules+ _ <- defineNamespacedVar env macroNamespace keyword $ Syntax (Just env) Nothing False identifiers rules continueEval env cont $ Nil "" eval env cont args@(List [Atom "if", predic, conseq, alt]) = do
hs-src/Language/Scheme/Macro.hs view
@@ -40,6 +40,7 @@ ( macroEval , loadMacros + , expand ) where import Language.Scheme.Types import Language.Scheme.Variables@@ -113,7 +114,7 @@ isDefined <- liftIO $ isNamespacedRecBound env macroNamespace x if isDefined then do- Syntax defEnv identifiers rules <- getNamespacedVar env macroNamespace x+ Syntax (Just defEnv) _ definedInMacro 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@@ -121,8 +122,11 @@ -- 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...- expanded <- macroTransform defEnv env renameEnv cleanupEnv (List identifiers) rules lisp+ expanded <- macroTransform defEnv env env renameEnv cleanupEnv + definedInMacro + (List identifiers) rules lisp macroEval env expanded -- Useful debug to see all exp's: (trace ("exp = " ++ show expanded) expanded)+-- macroEval env (trace ("exp = " ++ show expanded) expanded) else return lisp -- No macro to process, just return code as it is...@@ -140,20 +144,20 @@ - rules - pattern/transform pairs to compare to input - input - Code from the scheme application -}-macroTransform :: Env -> Env -> Env -> Env -> LispVal -> [LispVal] -> LispVal -> IOThrowsError LispVal-macroTransform defEnv env renameEnv cleanupEnv identifiers (rule@(List _) : rs) input = do+macroTransform :: Env -> Env -> Env -> Env -> Env -> Bool -> LispVal -> [LispVal] -> LispVal -> IOThrowsError LispVal+macroTransform defEnv env divertEnv renameEnv cleanupEnv dim identifiers (rule@(List _) : rs) input = do localEnv <- liftIO $ nullEnv -- Local environment used just for this invocation -- to hold pattern variables- result <- matchRule defEnv env identifiers localEnv renameEnv cleanupEnv rule input+ result <- matchRule defEnv env divertEnv dim identifiers localEnv renameEnv cleanupEnv rule input case result of -- No match, check the next rule- Nil _ -> macroTransform defEnv env renameEnv cleanupEnv identifiers rs input+ Nil _ -> macroTransform defEnv env divertEnv renameEnv cleanupEnv dim identifiers rs input _ -> do -- Walk the resulting code, performing the Clinger algorithm's 4 components- walkExpanded defEnv env renameEnv cleanupEnv True False (List []) (result)+ walkExpanded defEnv env divertEnv renameEnv cleanupEnv dim 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@@ -167,8 +171,8 @@ {- Given input, determine if that input matches any rules @return Transformed code, or Nil if no rules match -}-matchRule :: Env -> Env -> LispVal -> Env -> Env -> Env -> LispVal -> LispVal -> IOThrowsError LispVal-matchRule defEnv outerEnv identifiers localEnv renameEnv cleanupEnv (List [pattern, template]) (List inputVar) = do+matchRule :: Env -> Env -> Env -> Bool -> LispVal -> Env -> Env -> Env -> LispVal -> LispVal -> IOThrowsError LispVal+matchRule defEnv outerEnv divertEnv dim 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@@ -183,7 +187,7 @@ case match of Bool False -> return $ Nil "" _ -> do- transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers 0 [] (List []) template+ transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers 0 [] (List []) template _ -> throwError $ BadSpecialForm "Malformed rule in syntax-rules" $ String $ show p where@@ -192,29 +196,29 @@ checkPattern ps@(DottedList ds d : _) is True = do case is of (DottedList _ _ : _) -> do - loadLocal defEnv outerEnv localEnv renameEnv identifiers + loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers (List $ ds ++ [d, Atom "..."]) (List is) 0 [] (flagDottedLists [] (False, False) 0) (List _ : _) -> do - loadLocal defEnv outerEnv localEnv renameEnv identifiers + loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers (List $ ds ++ [d, Atom "..."]) (List is) 0 [] (flagDottedLists [] (True, False) 0)- _ -> loadLocal defEnv outerEnv localEnv renameEnv identifiers (List ps) (List is) 0 [] []+ _ -> loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers (List ps) (List is) 0 [] [] -- No pair, immediately begin matching- checkPattern ps is _ = loadLocal defEnv outerEnv localEnv renameEnv identifiers (List ps) (List is) 0 [] [] + checkPattern ps is _ = loadLocal defEnv outerEnv divertEnv 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] {- loadLocal - Determine if pattern matches input, loading input into pattern variables as we go, in preparation for macro transformation. -}-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+loadLocal :: Env -> Env -> Env -> Env -> Env -> LispVal -> LispVal -> LispVal -> Int -> [Int] -> [(Bool, Bool)] -> IOThrowsError LispVal+loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers pattern input ellipsisLevel ellipsisIndex listFlags = do case (pattern, input) of ((DottedList ps p), (DottedList isRaw iRaw)) -> do@@ -226,11 +230,11 @@ let is = fst isSplit let i = (snd isSplit) ++ [iRaw] - result <- loadLocal defEnv outerEnv localEnv renameEnv identifiers (List ps) (List is) ellipsisLevel ellipsisIndex listFlags+ result <- loadLocal defEnv outerEnv divertEnv 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 defEnv outerEnv localEnv renameEnv identifiers + loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers (List $ [p, Atom "..."]) (List i) ellipsisLevel -- Incremented in the list/list match below@@ -254,7 +258,7 @@ else ellipsisIndex -- At this point we know if the input is part of an ellipsis, so set the level accordingly - status <- checkLocal defEnv outerEnv (localEnv) renameEnv identifiers level idx p i listFlags+ status <- checkLocal defEnv outerEnv divertEnv (localEnv) renameEnv identifiers level idx p i listFlags case (status) of -- No match Bool False -> if nextHasEllipsis@@ -263,16 +267,16 @@ then do case ps of [Atom "..."] -> return $ Bool True -- An otherwise empty list, so just let the caller know match is done- _ -> loadLocal defEnv outerEnv localEnv renameEnv identifiers (List $ tail ps) (List (i : is)) ellipsisLevel ellipsisIndex listFlags+ _ -> loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers (List $ tail ps) (List (i : is)) ellipsisLevel ellipsisIndex listFlags else return $ Bool False -- There was a match _ -> if nextHasEllipsis then - loadLocal defEnv outerEnv localEnv renameEnv identifiers pattern (List is)+ loadLocal defEnv outerEnv divertEnv 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 defEnv outerEnv localEnv renameEnv identifiers (List ps) (List is) ellipsisLevel ellipsisIndex listFlags+ else loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers (List ps) (List is) ellipsisLevel ellipsisIndex listFlags -- Base case - All data processed (List [], List []) -> return $ Bool True@@ -293,7 +297,7 @@ (List [], _) -> return $ Bool False -- Check input against pattern (both should be single var)- (_, _) -> checkLocal defEnv outerEnv localEnv renameEnv identifiers ellipsisLevel ellipsisIndex pattern input listFlags+ (_, _) -> checkLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers ellipsisLevel ellipsisIndex pattern input listFlags -- -- |Utility function to flag pattern variables as 'no match' that exist in the @@ -374,6 +378,7 @@ -- Check pattern against input to determine if there is a match checkLocal :: Env -- Environment where the macro was defined -> Env -- Outer environment where this macro was called+ -> Env -- Outer env that the macro may divert values back to -> 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@@ -383,12 +388,12 @@ -> 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 defEnv outerEnv localEnv renameEnv 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 divertEnv localEnv renameEnv identifiers ellipsisLevel ellipsisIndex (Atom pattern) input listFlags = do -- TODO: --@@ -494,26 +499,26 @@ _ <- defineNamespacedVar localEnv "improper pattern" pat $ Bool $ fst flags defineNamespacedVar localEnv "improper input" pat $ Bool $ snd flags -checkLocal defEnv outerEnv localEnv renameEnv identifiers ellipsisLevel ellipsisIndex (Vector p) (Vector i) flags =+checkLocal defEnv outerEnv divertEnv 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 defEnv outerEnv localEnv renameEnv identifiers (List $ elems p) (List $ elems i) ellipsisLevel ellipsisIndex flags+ loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers (List $ elems p) (List $ elems i) 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 defEnv outerEnv divertEnv localEnv renameEnv identifiers ellipsisLevel ellipsisIndex pattern@(DottedList _ _) input@(DottedList _ _) flags =+ loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers pattern input ellipsisLevel ellipsisIndex flags -checkLocal defEnv outerEnv localEnv renameEnv identifiers ellipsisLevel ellipsisIndex (DottedList ps p) input@(List (_ : _)) flags = do- loadLocal defEnv outerEnv localEnv renameEnv identifiers +checkLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers ellipsisLevel ellipsisIndex (DottedList ps p) input@(List (_ : _)) flags = do+ loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers (List $ ps ++ [p, Atom "..."]) input ellipsisLevel -- Incremented in the list/list match below ellipsisIndex (flagDottedLists flags (True, False) $ length ellipsisIndex)-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 defEnv outerEnv divertEnv localEnv renameEnv identifiers ellipsisLevel ellipsisIndex pattern@(List _) input@(List _) flags =+ loadLocal defEnv outerEnv divertEnv 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.@@ -540,31 +545,80 @@ return $ eqVal d u matchIdent _ _ = return False -- Not defined in one place, reject it +-- |This function walks the given block of code using the macro expansion algorithm,+-- recursively expanding macro calls as they are encountered.+--+-- It is essentially a wrapper for the function walkExpanded which is internal to this module.+expand :: Env -> Bool -> LispVal -> IOThrowsError LispVal+expand env dim code = do+ renameEnv <- liftIO $ nullEnv+ cleanupEnv <- liftIO $ nullEnv++-- TODO: not sure if it is a problem to use env for both def and use, however I cannot think+-- of anything else to use below.+--+-- However, I believe this does highlight problems later on where defEnv is taken from the+-- function parameter instead of the Syntax object+--++ walkExpanded env env env renameEnv cleanupEnv dim True False (List []) code+ -- |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 :: Env -> Env -> Env -> Env -> Env -> Bool -> Bool -> Bool -> LispVal -> LispVal -> IOThrowsError LispVal+walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim _ isQuoted (List result) (List (List l : ls)) = do+ lst <- walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim True isQuoted (List []) (List l)+ walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim 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 divertEnv renameEnv cleanupEnv dim _ isQuoted (List result) (List ((Vector v) : vs)) = do+ List lst <- walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False isQuoted (List []) (List $ elems v)+ walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim 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 divertEnv renameEnv cleanupEnv dim _ isQuoted (List result) (List ((DottedList ds d) : ts)) = do+ List ls <- walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False isQuoted (List []) (List ds)+ l <- walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False isQuoted (List []) d+ walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False isQuoted (List $ result ++ [DottedList ls l]) (List ts) -walkExpanded defEnv useEnv renameEnv cleanupEnv startOfList inputIsQuoted (List result) transform@(List (Atom aa : ts)) = do+walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim 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+ walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim startOfList inputIsQuoted (List result) + (a) ts isQuoted isDefinedAsMacro++-- Transform anything else as itself...+walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim _ isQuoted (List result) (List (t : ts)) = do+ walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim 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++walkExpandedAtom :: Env + -> Env + -> Env + -> Env + -> Env + -> Bool + -> Bool + -> Bool + -> LispVal + -> String + -> [LispVal] + -> Bool -- is Quoted+ -> Bool -- is defined as macro+ -> IOThrowsError LispVal+ {- Some high-level design notes on how this could be made to work: @@ -587,59 +641,143 @@ -- TODO: error else -}- if (startOfList) && a == "define-syntax" && not isQuoted- then case ts of- [Atom keyword, (List (Atom "syntax-rules" : (List identifiers : rules)))] -> do++walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim True inputIsQuoted (List result)+ "let-syntax" + (List bindings : body)+ False _ = do++-- TODO: use of bodyEnv is not entirely correct because diverted vars will be lost!+-- may need to pass one more env around for divert...++ bodyEnv <- liftIO $ extendEnv useEnv []+ _ <- loadMacros useEnv bodyEnv (Just renameEnv) True bindings+ expanded <- walkExpanded defEnv bodyEnv divertEnv renameEnv cleanupEnv dim True inputIsQuoted (List [Atom "lambda", List []]) (List body)+ return $ List [expanded]++walkExpandedAtom _ _ _ _ _ _ True _ _ "let-syntax" ts False _ = do+ throwError $ BadSpecialForm "Malformed let-syntax expression" $ List (Atom "let-syntax" : ts)++walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim True inputIsQuoted (List result)+ "letrec-syntax" + (List bindings : body)+ False _ = do++-- TODO: use of bodyEnv is not entirely correct because diverted vars will be lost!+-- may need to pass one more env around for divert...++ bodyEnv <- liftIO $ extendEnv useEnv []+ _ <- loadMacros bodyEnv bodyEnv (Just renameEnv) True bindings+ expanded <- walkExpanded defEnv bodyEnv divertEnv renameEnv cleanupEnv dim True inputIsQuoted (List [Atom "lambda", List []]) (List body)+ return $ List [expanded]++walkExpandedAtom _ _ _ _ _ _ True _ _ "letrec-syntax" ts False _ = do+ throwError $ BadSpecialForm "Malformed letrec-syntax expression" $ List (Atom "letrec-syntax" : ts)++walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim True inputIsQuoted (List result)+ "define-syntax" + ts@([Atom keyword, (List (Atom "syntax-rules" : (List identifiers : rules)))])+ False _ = do -- Do we need to rename the keyword, or at least take that into account?- _ <- defineNamespacedVar useEnv macroNamespace keyword $ Syntax useEnv identifiers rules+ renameEnvClosure <- liftIO $ copyEnv renameEnv+ _ <- defineNamespacedVar useEnv macroNamespace keyword $ Syntax (Just useEnv) (Just renameEnvClosure) True 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)+walkExpandedAtom _ _ _ _ _ _ True _ _ "define-syntax" ts False _ = do+ throwError $ BadSpecialForm "Malformed define-syntax expression" $ List (Atom "define-syntax" : 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+{-+ - Notes regarding define and set+ -+TODO: need to call a new function to scan for define (and set! ??) forms. +if found, need to add an entry to renameEnv (?) so as to get the transLiteral+code to work. otherwise there is no way for that code to know that a (define)+called within a macro is inserting a new binding.+do not actually need to do anything to the (define) form, just mark somehow+that it is inserting a binding for the var+-} --- Single atom, rename (if necessary) and return-walkExpanded _ _ renameEnv _ _ _ _ (Atom a) = expandAtom renameEnv (Atom a)+walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim True inputIsQuoted (List result)+ "define" + [Atom var, val]+ False _ = do+ _ <- defineVar renameEnv var $ Atom var+ walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False False (List [Atom "define", {-head renamedVars-} Atom var]) (List [val])+walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim True _ (List result) a@"define" ts False _ = do+ -- define is malformed, just transform as normal atom...+ walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False False (List $ result ++ [Atom a]) (List ts) --- 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+walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim True inputIsQuoted (List result)+ "set!" + [Atom var, val]+ False _ = do+ isLexicalDef <- liftIO $ isRecBound useEnv var+ isAlreadyRenamed <- liftIO $ isRecBound renameEnv var+ case (isLexicalDef, isAlreadyRenamed) of+ -- Only create a new record for this variable if it has not yet been+ -- seen within this macro. Otherwise the existing algorithms will handle+ -- everything just fine...+ (True, False) -> do+ _ <- defineVar renameEnv var $ Atom var+ walk+ _ -> walk+ where+ walk = walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False False (List [Atom "set!"]) (List [Atom var, val]) +walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim True _ (List result) a@"set!" ts False _ = do+ -- define is malformed, just transform as normal atom...+ walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False False (List $ result ++ [Atom a]) (List ts)++walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim True inputIsQuoted (List result)+ "lambda" + (List vars : fbody)+ False _ = do+-- Placed here, the lambda primitive trumps a macro of the same name... (desired behavior?)+ -- 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 divertEnv env cleanupEnv dim True False (List [Atom "lambda", renamedVars]) (List fbody)+walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim True _ (List result) a@"lambda" ts False _ = do+ -- lambda is malformed, just transform as normal atom...+ walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False False (List $ result ++ [Atom a]) (List ts)++walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim True inputIsQuoted (List result)+ a+ ts + False True = do+ syn <- getNamespacedVar useEnv macroNamespace a+ case syn of+-- TODO: why do we assume that defEnv is the same as the one defined for the macro? Should read+-- this out of the Syntax object+ Syntax _ (Just renameClosure) definedInMacro identifiers rules -> do + macroTransform defEnv useEnv divertEnv renameClosure cleanupEnv definedInMacro (List identifiers) rules (List (Atom a : ts))+ Syntax _ _ definedInMacro identifiers rules -> do + -- 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 divertEnv renameEnv cleanupEnv definedInMacro (List identifiers) rules (List (Atom a : ts))++walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim _ inputIsQuoted (List result)+ a+ ts+ True _ = do+ let isQuasiQuoted = (a == "quasiquote")+ -- Cleanup all symbols in the quoted code+ List cleaned <- cleanExpanded + defEnv useEnv divertEnv renameEnv cleanupEnv + dim True isQuasiQuoted + (List []) (List ts)+ return $ List $ result ++ (Atom a : cleaned)++walkExpandedAtom defEnv useEnv divertEnv renameEnv cleanupEnv dim _ inputIsQuoted (List result)+ a ts isQuoted _ = do+ walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv + dim False isQuoted + (List $ result ++ [Atom a]) (List ts)+ -- |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.@@ -675,22 +813,22 @@ -- 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 :: Env -> Env -> Env -> Env -> Env -> Bool -> 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 divertEnv renameEnv cleanupEnv dim _ isQQ (List result) (List (List l : ls)) = do+ lst <- cleanExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim True isQQ (List []) (List l)+ cleanExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim 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 divertEnv renameEnv cleanupEnv dim _ isQQ (List result) (List ((Vector v) : vs)) = do+ List lst <- cleanExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim True isQQ (List []) (List $ elems v)+ cleanExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim 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 divertEnv renameEnv cleanupEnv dim _ isQQ (List result) (List ((DottedList ds d) : ts)) = do+ List ls <- cleanExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim True isQQ (List []) (List ds)+ l <- cleanExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim True isQQ (List []) d+ cleanExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False isQQ (List $ result ++ [DottedList ls l]) (List ts) -cleanExpanded defEnv useEnv renameEnv cleanupEnv startOfList isQQ (List result) (List (Atom a : ts)) = do+cleanExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim 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@@ -701,10 +839,10 @@ -- - An "unquote" is found -- (True, True, Atom "unquote") -> do - r <- walkExpanded defEnv useEnv renameEnv cleanupEnv True False (List $ result ++ [Atom "unquote"]) (List ts)+ r <- walkExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim True False (List $ result ++ [Atom "unquote"]) (List ts) return r _ -> - cleanExpanded defEnv useEnv renameEnv cleanupEnv False isQQ (List $ result ++ [expanded]) (List ts)+ cleanExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim 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@@ -718,16 +856,16 @@ 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)+cleanExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim _ isQQ (List result) (List (t : ts)) = do+ cleanExpanded defEnv useEnv divertEnv renameEnv cleanupEnv dim False isQQ (List $ result ++ [t]) (List ts) -- Base case - empty transform-cleanExpanded _ _ _ _ _ _ result@(List _) (List []) = do+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+cleanExpanded _ _ _ _ _ _ _ _ _ transform = return transform {- |Transform input by walking the tranform structure and creating a new structure@@ -740,9 +878,11 @@ -} transformRule :: Env -- ^ Environment the macro was defined in -> Env -- ^ Outer, enclosing environment+ -> Env -- ^ Outer environment that the macro may divert values back to -> 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 + -> Bool -> 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@@ -753,58 +893,58 @@ -> IOThrowsError LispVal -- Recursively transform a list-transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex (List result) transform@(List (List l : ts)) = do+transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim 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 defEnv outerEnv localEnv renameEnv cleanupEnv identifiers level idx (List []) (List l)+ curT <- transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers level idx (List []) (List l) case (curT) of Nil _ -> -- No match ("zero" case). Use tail to move past the "..."- continueTransform defEnv outerEnv localEnv renameEnv cleanupEnv identifiers + continueTransform defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel (init ellipsisIndex) -- Issue #56 - done w/ellip so no need for last idx result $ tail ts- List _ -> transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers + List _ -> transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim 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 defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex (List []) (List l)+ lst <- transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List []) (List l) case lst of- List _ -> transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex (List $ result ++ [lst]) (List ts)+ List _ -> transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim 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 defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex (List result) transform@(List ((Vector v) : ts)) = do+transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim 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 defEnv outerEnv localEnv renameEnv cleanupEnv identifiers level idx (List []) (List $ elems v)+ curT <- transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim 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 defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel (init ellipsisIndex) result $ tail ts- List t -> transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers + continueTransform defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel (init ellipsisIndex) result $ tail ts+ List t -> transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim 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 defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex (List []) (List $ elems v)+ else do lst <- transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List []) (List $ elems v) case lst of- List l -> transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex (List $ result ++ [asVector l]) (List ts)+ List l -> transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim 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] -- Recursively transform an improper list-transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex (List result) transform@(List (dl@(DottedList _ _) : ts)) = do+transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim 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@@ -812,18 +952,18 @@ -- 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 defEnv outerEnv localEnv renameEnv cleanupEnv identifiers level idx (List []) (List [dl])+ curT <- transformDottedList defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers level idx (List []) (List [dl]) case curT of Nil _ -> -- No match ("zero" case). Use tail to move past the "..."- continueTransform defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel (init ellipsisIndex) result $ tail ts - List t -> transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers + continueTransform defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel (init ellipsisIndex) result $ tail ts + List t -> transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim 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 defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex (List []) (List [dl])+ else do lst <- transformDottedList defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List []) (List [dl]) case lst of- List l -> transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex (List $ result ++ l) (List ts)+ List l -> transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List $ result ++ l) (List ts) Nil _ -> return lst _ -> throwError $ BadSpecialForm "transformRule: Macro transform error" $ List [lst, (List [dl]), Number $ toInteger ellipsisLevel] @@ -832,7 +972,7 @@ -- 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+transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim 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 @@ -845,7 +985,7 @@ where literalHere = do- expanded <- transformLiteralIdentifier defEnv outerEnv localEnv a+ expanded <- transformLiteralIdentifier defEnv outerEnv divertEnv renameEnv dim a if hasEllipsis then do -- Skip over ellipsis if present@@ -856,7 +996,7 @@ -- 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)+ transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim 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@@ -889,15 +1029,15 @@ 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 defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex (List $ result ++ aa) (List $ tail ts)+ List aa -> transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List $ result ++ aa) (List $ tail ts) _ -> -- No matches for var- continueTransform defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex result $ tail ts+ continueTransform defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex result $ tail ts Nil "" -> -- No matches, keep going- 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)+ continueTransform defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex result $ tail ts+ v@(_) -> transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List $ result ++ [v]) (List $ tail ts) else -- Matched 0 times, skip it- transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex (List result) (List $ tail ts)+ transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List result) (List $ tail ts) noEllipsis isDefined = do isImproperPattern <- loadNamespacedBool "improper pattern"@@ -975,20 +1115,20 @@ -- Continue calling into transformRule continueTransformWith results = - transformRule defEnv outerEnv + transformRule defEnv outerEnv divertEnv localEnv- renameEnv cleanupEnv identifiers + renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List $ results) (List ts) -- Transform anything else as itself...-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) +transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List result) (List (t : ts)) = do+ transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim 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 a single var@@ -997,22 +1137,25 @@ -- 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+transformRule defEnv outerEnv divertEnv localEnv renameEnv _ dim 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+ else transformLiteralIdentifier defEnv outerEnv divertEnv renameEnv dim 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+transformLiteralIdentifier :: Env -> Env -> Env -> Env -> Bool -> String -> IOThrowsError LispVal+transformLiteralIdentifier defEnv outerEnv divertEnv renameEnv definedInMacro transform = do isInDef <- liftIO $ isRecBound defEnv transform- if isInDef+ isRenamed <- liftIO $ isRecBound renameEnv transform+-- if (trace ("a = " ++ transform ++ " inDef = " ++ show isInDef ++ " isRnm = " ++ show isRenamed ++ " dim = " ++ show definedInMacro) isInDef) && not isRenamed+-- TODO: isRenamed should only matter if the macro was originally defined within another macro+ if (isInDef && not definedInMacro) || (isInDef && definedInMacro && not isRenamed) then do {- Variable exists in the environment the macro was defined in, so divert that value back into the environment of use. The value@@ -1020,7 +1163,7 @@ a variable of the same name in env of use. -} value <- getVar defEnv transform Atom renamed <- _gensym transform- _ <- defineVar outerEnv renamed value + _ <- defineVar divertEnv renamed value return $ Atom renamed else do {- TODO: @@ -1045,9 +1188,9 @@ return $ Atom transform -- | A helper function for transforming an improper list-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)+transformDottedList :: Env -> Env -> Env -> Env -> Env -> Env -> Bool -> LispVal -> Int -> [Int] -> LispVal -> LispVal -> IOThrowsError LispVal+transformDottedList defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List result) (List (DottedList ds d : ts)) = do+ lsto <- transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List []) (List ds) case lsto of List lst -> do -- Similar logic to the parser is applied here, where@@ -1055,7 +1198,7 @@ -- they form a proper list -- -- d is an n-ary match, per Issue #34- r <- transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers + r <- transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel -- OK not to increment here, this is accounted for later on ellipsisIndex -- Same as above (List []) @@ -1063,11 +1206,11 @@ case r of -- Trailing symbol in the pattern may be neglected in the transform, so skip it... List [] ->- transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex (List $ result ++ [List lst]) (List ts)+ transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List $ result ++ [List lst]) (List ts) Nil _ -> -- Same as above, no match for d, so skip it - transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex (List $ result ++ [List lst]) (List ts)+ transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List $ result ++ [List lst]) (List ts) List rst -> do- transformRule defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex + transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (buildTransformedCode result lst rst) (List ts) _ -> throwError $ BadSpecialForm "Macro transform error processing pair" $ DottedList ds d Nil _ -> return $ Nil ""@@ -1090,16 +1233,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 -> Env -> Env -> Env -> LispVal -> Int -> [Int] -> [LispVal] -> [LispVal] -> IOThrowsError LispVal-continueTransform defEnv outerEnv localEnv renameEnv cleanupEnv identifiers ellipsisLevel ellipsisIndex result remaining = do+continueTransform :: Env -> Env -> Env -> Env -> Env -> Env -> Bool -> LispVal -> Int -> [Int] -> [LispVal] -> [LispVal] -> IOThrowsError LispVal+continueTransform defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex result remaining = do if not (null remaining)- then transformRule defEnv outerEnv + then transformRule defEnv outerEnv divertEnv localEnv renameEnv- cleanupEnv identifiers+ cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List result) @@ -1145,11 +1288,14 @@ -- |Helper function to load macros from a let*-syntax expression loadMacros :: Env -- ^ Parent environment containing the let*-syntax expression -> Env -- ^ Environment of the let*-syntax body+ -> Maybe Env -- ^ Environment of renamed variables, if applicable+ -> Bool -- ^ True if the macro was defined inside another macro -> [LispVal] -- ^ List containing syntax-rule definitions -> IOThrowsError LispVal -- ^ A dummy value, unless an error is thrown-loadMacros e be (List [Atom keyword, (List (Atom "syntax-rules" : (List identifiers : rules)))] : bs) = do+loadMacros e be re dim (List [Atom keyword, (List (Atom "syntax-rules" : (List identifiers : rules)))] : bs) = do -- TODO: error checking- _ <- defineNamespacedVar be macroNamespace keyword $ Syntax e identifiers rules- loadMacros e be bs-loadMacros e be [] = return $ Nil ""-loadMacros _ _ form = throwError $ BadSpecialForm "Unable to evaluate form" $ List form + _ <- defineNamespacedVar be macroNamespace keyword $ + Syntax (Just e) re dim identifiers rules+ loadMacros e be re dim bs+loadMacros _ _ _ _ [] = return $ Nil ""+loadMacros _ _ _ _ form = throwError $ BadSpecialForm "Unable to evaluate form" $ List form
hs-src/Language/Scheme/Types.hs view
@@ -151,12 +151,12 @@ , 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?-+ | Syntax { synClosure :: Maybe Env -- ^ Code env in effect at definition time, if applicable+ , synRenameClosure :: Maybe Env -- ^ Renames (from macro hygiene) in effect at def time;+ -- only applicable if this macro defined inside another macro.+ , synDefinedInMacro :: Bool+ , synIdentifiers :: [LispVal] -- ^ Literal identifiers from syntax-rules + , synRules :: [LispVal] -- ^ Rules from syntax-rules } -- ^ 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@@ -275,7 +275,7 @@ showVal (DottedList h t) = "(" ++ unwordsList h ++ " . " ++ showVal t ++ ")" showVal (PrimitiveFunc _) = "<primitive>" showVal (Continuation _ _ _ _ _) = "<continuation>"-showVal (Syntax _ _ _) = "<syntax>"+showVal (Syntax _ _ _ _ _) = "<syntax>" showVal (Func {params = args, vararg = varargs, body = _, closure = _}) = "(lambda (" ++ unwords (map show args) ++ (case varargs of
hs-src/shell.hs view
@@ -67,7 +67,7 @@ putStrLn " | | | | |_| \\__ \\ < /// \\\\\\ \\__ \\ (__| | | | __/ | | | | | __/ " putStrLn " |_| |_|\\__,_|___/_|\\_\\ /// \\\\\\ |___/\\___|_| |_|\\___|_| |_| |_|\\___| " putStrLn " "- putStrLn " husk Scheme Interpreter Version 3.4.1 "+ putStrLn " husk Scheme Interpreter Version 3.4.2 " putStrLn " (c) 2010-2011 Justin Ethier github.com/justinethier/husk-scheme " putStrLn " "
husk-scheme.cabal view
@@ -1,5 +1,5 @@ Name: husk-scheme-Version: 3.4.1+Version: 3.4.2 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,