husk-scheme 3.2.1 → 3.3
raw patch · 9 files changed
+819/−416 lines, 9 filesdep ~haskell98
Dependency ranges changed: haskell98
Files
- README.markdown +1/−1
- hs-src/Language/Scheme/Core.hs +11/−76
- hs-src/Language/Scheme/FFI.hs +88/−0
- hs-src/Language/Scheme/Macro.hs +496/−316
- hs-src/Language/Scheme/Macro/Matches.hs +167/−0
- hs-src/Language/Scheme/Parser.hs +22/−1
- hs-src/shell.hs +1/−1
- husk-scheme.cabal +9/−5
- stdlib.scm +24/−16
README.markdown view
@@ -98,7 +98,7 @@ The `examples` directory contains example scheme programs. -Patches are welcome; please send via pull request on github.+Patches are welcome! Please send them via a pull request on github. Also, when making code changes please try to add at least one test case for your change, and ensure that the change does not break any existing unit tests. License -------
hs-src/Language/Scheme/Core.hs view
@@ -5,7 +5,7 @@ Maintainer : github.com/justinethier Stability : experimental-Portability : non-portable (GHC API)+Portability : portable husk scheme interpreter @@ -15,13 +15,13 @@ -} module Language.Scheme.Core- (- eval+ ( eval , evalLisp , evalString , evalAndPrint , primitiveBindings ) where+import qualified Language.Scheme.FFI import Language.Scheme.Macro import Language.Scheme.Numerical import Language.Scheme.Parser@@ -32,11 +32,6 @@ import Data.Array import qualified Data.Map import IO hiding (try)--import qualified GHC-import qualified GHC.Paths (libdir)-import qualified DynFlags-import qualified Unsafe.Coerce (unsafeCoerce) --import Debug.Trace {- |Evaluate a string containing Scheme code.@@ -647,7 +642,7 @@ {- These functions have access to the current environment via the current continuation, which is passed as the first LispVal argument. -} ---evalfuncApply, evalfuncDynamicWind, evalfuncEval, evalfuncLoad, evalfuncLoadFFI, evalfuncCallCC, evalfuncCallWValues :: [LispVal] -> IOThrowsError LispVal+evalfuncApply, evalfuncDynamicWind, evalfuncEval, evalfuncLoad, evalfuncCallCC, evalfuncCallWValues :: [LispVal] -> IOThrowsError LispVal {- - A (somewhat) simplified implementation of dynamic-wind@@ -696,74 +691,15 @@ evalfuncApply _ = throwError $ NumArgs 2 [] evalfuncLoad [cont@(Continuation env _ _ _ _), String filename] = do- result <- load filename >>= liftM last . mapM (evaluate env (makeNullContinuation env))- continueEval env cont result+ 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 evalfuncLoad (_ : args) = throwError $ NumArgs 1 args -- Skip over continuation argument evalfuncLoad _ = throwError $ NumArgs 1 [] -{-- - |Load a Haskell function into husk using the foreign function inteface (FFI)- -- - Based on example code from:- -- - http://stackoverflow.com/questions/5521129/importing-a-known-function-from-an-already-compiled-binary-using-ghcs-api-or-hi- - and- - http://www.bluishcoder.co.nz/2008/11/dynamic-compilation-and-loading-of.html- -- -- - TODO: pass a list of functions to import. Need to make sure this is done in an efficient way- - (IE, result as a list that can be processed) - -}-evalfuncLoadFFI [cont@(Continuation env _ _ _ _), String targetSrcFile,- String moduleName,- String externalFuncName,- String internalFuncName] = do- result <- liftIO $ defaultRunGhc $ do- dynflags <- GHC.getSessionDynFlags- _ <- GHC.setSessionDynFlags dynflags- -- let m = GHC.mkModule (GHC.thisPackage dynflags) (GHC.mkModuleName "Test")-----{- TODO: migrate duplicate code into helper functions to drive everything-FUTURE: should be able to load multiple functions in one shot (?). -}---- target <- GHC.guessTarget targetSrcFile Nothing- GHC.addTarget target- r <- GHC.load GHC.LoadAllTargets- case r of- GHC.Failed -> error "Compilation failed"- GHC.Succeeded -> do- m <- GHC.findModule (GHC.mkModuleName moduleName) Nothing-#if __GLASGOW_HASKELL__ < 700- GHC.setContext [] [m]-#else- GHC.setContext [] [(m, Nothing)]-#endif- fetched <- GHC.compileExpr (moduleName ++ "." ++ externalFuncName)- return (Unsafe.Coerce.unsafeCoerce fetched :: [LispVal] -> IOThrowsError LispVal)- defineVar env internalFuncName (IOFunc result) >>= continueEval env cont---- Overload that loads code from a compiled module-evalfuncLoadFFI [cont@(Continuation env _ _ _ _), String moduleName, String externalFuncName, String internalFuncName] = do- result <- liftIO $ defaultRunGhc $ do- dynflags <- GHC.getSessionDynFlags- _ <- GHC.setSessionDynFlags dynflags- m <- GHC.findModule (GHC.mkModuleName moduleName) Nothing-#if __GLASGOW_HASKELL__ < 700- GHC.setContext [] [m]-#else- GHC.setContext [] [(m, Nothing)]-#endif- fetched <- GHC.compileExpr (moduleName ++ "." ++ externalFuncName)- return (Unsafe.Coerce.unsafeCoerce fetched :: [LispVal] -> IOThrowsError LispVal)- defineVar env internalFuncName (IOFunc result) >>= continueEval env cont--evalfuncLoadFFI _ = throwError $ NumArgs 3 []--defaultRunGhc :: GHC.Ghc a -> IO a-defaultRunGhc = GHC.defaultErrorHandler DynFlags.defaultDynFlags . GHC.runGhc (Just GHC.Paths.libdir)- -- Evaluate an expression in the current environment -- -- Assumption is any macro transform is already performed@@ -792,14 +728,13 @@ {- Primitive functions that extend the core evaluator -} evalFunctions :: [(String, [LispVal] -> IOThrowsError LispVal)]-evalFunctions = [- ("apply", evalfuncApply)+evalFunctions = [ ("apply", evalfuncApply) , ("call-with-current-continuation", evalfuncCallCC) , ("call-with-values", evalfuncCallWValues) , ("dynamic-wind", evalfuncDynamicWind) , ("eval", evalfuncEval) , ("load", evalfuncLoad)- , ("load-ffi", evalfuncLoadFFI) -- Non-standard extension+ , ("load-ffi", Language.Scheme.FFI.evalfuncLoadFFI) -- Non-standard extension ] {- I/O primitives Primitive functions that execute within the IO monad -}
+ hs-src/Language/Scheme/FFI.hs view
@@ -0,0 +1,88 @@+{- |+Module : Language.Scheme.FFI+Copyright : Justin Ethier+Licence : MIT (see LICENSE in the distribution)++Maintainer : github.com/justinethier+Stability : experimental+Portability : non-portable (GHC API)++husk scheme interpreter++A lightweight dialect of R5RS scheme.++This module contains the foreign function interface.+-}+module Language.Scheme.FFI (evalfuncLoadFFI) where++import Language.Scheme.Types+import Language.Scheme.Variables+import Control.Monad.Error++import qualified GHC+import qualified GHC.Paths (libdir)+import qualified DynFlags+import qualified Unsafe.Coerce (unsafeCoerce)++evalfuncLoadFFI :: [LispVal] -> IOThrowsError LispVal+{-+ - |Load a Haskell function into husk using the foreign function inteface (FFI)+ -+ - Based on example code from:+ -+ - http://stackoverflow.com/questions/5521129/importing-a-known-function-from-an-already-compiled-binary-using-ghcs-api-or-hi+ - and+ - http://www.bluishcoder.co.nz/2008/11/dynamic-compilation-and-loading-of.html+ -+ -+ - TODO: pass a list of functions to import. Need to make sure this is done in an efficient way+ - (IE, result as a list that can be processed) + -}+evalfuncLoadFFI [(Continuation env _ _ _ _), String targetSrcFile,+ String moduleName,+ String externalFuncName,+ String internalFuncName] = do+ result <- liftIO $ defaultRunGhc $ do+ dynflags <- GHC.getSessionDynFlags+ _ <- GHC.setSessionDynFlags dynflags+ -- let m = GHC.mkModule (GHC.thisPackage dynflags) (GHC.mkModuleName "Test")++--+{- TODO: migrate duplicate code into helper functions to drive everything+FUTURE: should be able to load multiple functions in one shot (?). -}+--+ target <- GHC.guessTarget targetSrcFile Nothing+ GHC.addTarget target+ r <- GHC.load GHC.LoadAllTargets+ case r of+ GHC.Failed -> error "Compilation failed"+ GHC.Succeeded -> do+ m <- GHC.findModule (GHC.mkModuleName moduleName) Nothing+#if __GLASGOW_HASKELL__ < 700+ GHC.setContext [] [m]+#else+ GHC.setContext [] [(m, Nothing)]+#endif+ fetched <- GHC.compileExpr (moduleName ++ "." ++ externalFuncName)+ return (Unsafe.Coerce.unsafeCoerce fetched :: [LispVal] -> IOThrowsError LispVal)+ defineVar env internalFuncName (IOFunc result) -- >>= continueEval env cont++-- Overload that loads code from a compiled module+evalfuncLoadFFI [(Continuation env _ _ _ _), String moduleName, String externalFuncName, String internalFuncName] = do+ result <- liftIO $ defaultRunGhc $ do+ dynflags <- GHC.getSessionDynFlags+ _ <- GHC.setSessionDynFlags dynflags+ m <- GHC.findModule (GHC.mkModuleName moduleName) Nothing+#if __GLASGOW_HASKELL__ < 700+ GHC.setContext [] [m]+#else+ GHC.setContext [] [(m, Nothing)]+#endif+ fetched <- GHC.compileExpr (moduleName ++ "." ++ externalFuncName)+ return (Unsafe.Coerce.unsafeCoerce fetched :: [LispVal] -> IOThrowsError LispVal)+ defineVar env internalFuncName (IOFunc result) -- >>= continueEval env cont++evalfuncLoadFFI _ = throwError $ NumArgs 3 []++defaultRunGhc :: GHC.Ghc a -> IO a+defaultRunGhc = GHC.defaultErrorHandler DynFlags.defaultDynFlags . GHC.runGhc (Just GHC.Paths.libdir)
hs-src/Language/Scheme/Macro.hs view
@@ -25,12 +25,6 @@ 2) If a rule matches, 3) Transform by walking the transform, inserting variables as needed -Remaining Work:--* Dotted lists are not 100% correctly implemented. In particular, the transformation should- take into account whether the input was presented as a list or a pair, and replicate that- in the output.- -} module Language.Scheme.Macro@@ -39,19 +33,22 @@ ) where import Language.Scheme.Types import Language.Scheme.Variables+import qualified Language.Scheme.Macro.Matches as Matches import Control.Monad.Error import Data.Array --import Debug.Trace -- Only req'd to support trace, can be disabled at any time... -{- Nice FAQ regarding macro's, points out some of the limitations of current implementation-http://community.schemewiki.org/?scheme-faq-macros -}+{-+ Implementation notes: + 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):- -+ 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.@@ -69,28 +66,20 @@ _ <- defineNamespacedVar env macroNamespace keyword syntaxRules return $ Nil "" -- Sentinal value -{---- Inspect a list of code, and transform as necessary-macroEval env (List (x@(List _) : xs)) = do- first <- macroEval env x- rest <- mapM (macroEval env) xs- return $ List $ first : rest--}- {- Inspect code for macros - - Only a list form is required because a pattern may only consist - of a list here. From the spec: -- - "The <pattern> in a <syntax rule> is a list <pattern> that-begins with the keyword for the macro." + - "The <pattern> in a <syntax rule> is a list <pattern> that + - begins with the keyword for the macro." - -} macroEval env lisp@(List (Atom x : _)) = do isDefined <- liftIO $ isNamespacedRecBound env macroNamespace x isDefinedAsVar <- liftIO $ isBound env x -- TODO: Not entirely correct; for example if a macro and var -- are defined in same env with same name, which one should be selected?- if isDefined && not isDefinedAsVar --(trace (show "mEval [" ++ show lisp ++ ", " ++ show x ++ "]: " ++ show isDefined) isDefined)+ if isDefined && not isDefinedAsVar then do (List (Atom "syntax-rules" : (List identifiers : rules))) <- getNamespacedVar env macroNamespace x -- Transform the input and then call macroEval again, since a macro may be contained within...@@ -119,6 +108,7 @@ case result of Nil _ -> macroTransform env identifiers rs input _ -> return result+ -- Ran out of rules to match... macroTransform _ _ _ input = throwError $ BadSpecialForm "Input does not match a macro pattern" input @@ -139,20 +129,43 @@ let is = tail inputVar let p = case pattern of DottedList ds d -> case ds of- (Atom l : ls) -> List [Atom l, DottedList ls d]- _ -> pattern- _ -> pattern+ -- Fix for Issue #44 - detect when pattern's match should + -- be modified from a pair to an ellipsis+ (Atom l : ls) -> (List [Atom l, DottedList ls d], True)+ _ -> (pattern, False)+ _ -> (pattern, False) case p of- List (Atom _ : ps) -> do- match <- loadLocal outerEnv localEnv identifiers (List ps) (List is) False False+ ((List (Atom _ : ps)), flag) -> do+ match <- checkPattern ps is flag case match of Bool False -> return $ Nil "" _ -> do -- bindings <- findBindings localEnv pattern--- transformRule outerEnv (trace ("bindings = " ++ show bindings) localEnv) 0 (List []) template (List [])- transformRule outerEnv localEnv 0 (List []) template (List [])- _ -> throwError $ BadSpecialForm "Malformed rule in syntax-rules" p+ transformRule outerEnv localEnv 0 [] (List []) template+ _ -> throwError $ BadSpecialForm "Malformed rule in syntax-rules" $ String $ show p + where+ -- A pair at the outmost level must be transformed to use the ellipsis, + -- or else its nary match will not work properly during pattern matching. + checkPattern ps@(DottedList ds d : _) is True = do+ case is of+ (DottedList _ _ : _) -> do + loadLocal outerEnv localEnv identifiers + (List $ ds ++ [d, Atom "..."])+ (List is)+ 0 []+ (flagDottedLists [] (False, False) 0)+ (List _ : _) -> do + loadLocal outerEnv localEnv identifiers + (List $ ds ++ [d, Atom "..."])+ (List is)+ 0 []+ (flagDottedLists [] (True, False) 0)+ _ -> loadLocal outerEnv localEnv identifiers (List ps) (List is) 0 [] []++ -- No pair, immediately begin matching+ checkPattern ps is _ = loadLocal outerEnv localEnv identifiers (List ps) (List is) 0 [] [] + matchRule _ _ _ rule input = do throwError $ BadSpecialForm "Malformed rule in syntax-rules" $ List [Atom "rule: ", rule, Atom "input: ", input] @@ -177,77 +190,180 @@ {- 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 -> Bool -> Bool -> IOThrowsError LispVal-loadLocal outerEnv localEnv identifiers pattern input hasEllipsis outerHasEllipsis = do+loadLocal :: Env -> Env -> LispVal -> LispVal -> LispVal -> Int -> [Int] -> [(Bool, Bool)] -> IOThrowsError LispVal+loadLocal outerEnv localEnv identifiers pattern input ellipsisLevel ellipsisIndex listFlags = do case (pattern, input) of - {- For vectors, just use list match for now, since vector input matching just requires a- subset of that behavior. Should be OK since parser would catch problems with trying- to add pair syntax to a vector declaration. -}- ((Vector p), (Vector i)) -> do- loadLocal outerEnv localEnv identifiers (List $ elems p) (List $ elems i) False outerHasEllipsis+ ((DottedList ps p), (DottedList isRaw iRaw)) -> do+ + -- Split input into two sections: + -- is - required inputs that must be present+ -- i - variable length inputs to each compare against p + let isSplit = splitAt (length ps) isRaw+ let is = fst isSplit+ let i = (snd isSplit) ++ [iRaw] - ((DottedList ps p), (DottedList is i)) -> do- result <- loadLocal outerEnv localEnv identifiers (List ps) (List is) False outerHasEllipsis+ result <- loadLocal outerEnv localEnv identifiers (List ps) (List is) ellipsisLevel ellipsisIndex listFlags case result of- Bool True -> loadLocal outerEnv localEnv identifiers p i False outerHasEllipsis+ Bool True -> -- By matching on an elipsis we force the code + -- to match pagainst all elements in i. + loadLocal outerEnv localEnv identifiers + (List $ [p, Atom "..."]) + (List i)+ ellipsisLevel -- Incremented in the list/list match below+ ellipsisIndex+ (flagDottedLists listFlags (True, True) $ length ellipsisIndex) _ -> return $ Bool False (List (p : ps), List (i : is)) -> do -- check first input against first pattern, recurse... - let localHasEllipsis = macroElementMatchesMany pattern-- {- FUTURE: error if ... detected when there is an outer ... ????- no, this should (eventually) be allowed. See scheme-faq-macros -}+ let nextHasEllipsis = macroElementMatchesMany pattern+ let level = if nextHasEllipsis then ellipsisLevel + 1+ else ellipsisLevel+ let idx = if nextHasEllipsis + then if (length ellipsisIndex == level)+ -- This is not the first match, increment existing index+ then do+ let l = splitAt (level - 1) ellipsisIndex+ (fst l) ++ [(head (snd l)) + 1]+ -- First input element that matches pattern; start at 0+ else ellipsisIndex ++ [0]+ else ellipsisIndex - status <- checkLocal outerEnv localEnv identifiers (localHasEllipsis || outerHasEllipsis) p i- case status of+ -- 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+ case (status) of -- No match- Bool False -> if localHasEllipsis+ Bool False -> if nextHasEllipsis {- No match, must be finished with ... Move past it, but keep the same input. -} then do- loadLocal outerEnv localEnv identifiers (List $ tail ps) (List (i : is)) False outerHasEllipsis+ 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 else return $ Bool False -- There was a match- _ -> if localHasEllipsis- then loadLocal outerEnv localEnv identifiers pattern (List is) True outerHasEllipsis- else loadLocal outerEnv localEnv identifiers (List ps) (List is) False outerHasEllipsis+ _ -> if nextHasEllipsis+ then + loadLocal outerEnv localEnv 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 -- Base case - All data processed (List [], List []) -> return $ Bool True -- Ran out of input to process- (List (_ : ps), List []) -> do- {- Ensure any patterns that are not present in the input still- have their variables initialized so they are ready during trans. -}- _ <- initializePatternVars localEnv "list" identifiers pattern- if (macroElementMatchesMany pattern) && ((length ps) == 1)- then return $ Bool True- else return $ Bool False+ (List (_ : _), List []) -> do+ if (macroElementMatchesMany pattern)+ then do+ -- Ensure any patterns that are not present in the input still+ -- have their variables initialized so they are ready during transformation+ -- 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+ 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 (hasEllipsis || outerHasEllipsis) pattern input+ (_, _) -> checkLocal outerEnv localEnv identifiers ellipsisLevel ellipsisIndex pattern input listFlags -{- Check pattern against input to determine if there is a match- -- - @param localEnv - Local variables for the macro, used during transform- - @param hasEllipsis - Determine whether we are in a zero-or-many match.- - Used for loading local vars and NOT for purposes of matching.- - @param pattern - Pattern to match- - @param input - Input to be matched- -}-checkLocal :: Env -> Env -> LispVal -> Bool -> LispVal -> LispVal -> IOThrowsError LispVal-checkLocal _ _ _ _ (Bool pattern) (Bool input) = return $ Bool $ pattern == input-checkLocal _ _ _ _ (Number pattern) (Number input) = return $ Bool $ pattern == input-checkLocal _ _ _ _ (Float pattern) (Float input) = return $ Bool $ pattern == input-checkLocal _ _ _ _ (String pattern) (String input) = return $ Bool $ pattern == input-checkLocal _ _ _ _ (Char pattern) (Char input) = return $ Bool $ pattern == input-checkLocal outerEnv localEnv identifiers hasEllipsis (Atom pattern) input = do- if hasEllipsis+--+-- |Utility function to flag pattern variables as 'no match' that exist in the +-- pattern after input has run out. Note that this can only happen if the +-- remaining pattern is part of a zero-or-more match.+--+-- Extended for Issue #42 -+-- Flag whether an unmatched pattern variable was part of an improper list in the pattern+-- 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 outerEnv localEnv identifiers (DottedList ps p) partOfImproperPattern = do+ flagUnmatchedVars outerEnv localEnv identifiers (List $ ps ++ [p]) partOfImproperPattern++flagUnmatchedVars outerEnv localEnv identifiers (Vector p) partOfImproperPattern = do+ flagUnmatchedVars outerEnv localEnv identifiers (List $ elems p) partOfImproperPattern++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 _ _ _ (Atom "...") _ = return $ Bool True ++flagUnmatchedVars outerEnv localEnv identifiers (Atom p) partOfImproperPattern =+ flagUnmatchedAtom outerEnv localEnv identifiers p partOfImproperPattern++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+ 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?+ then return $ Bool True+ else do _ <- flagUnmatchedVar localEnv p improperListFlag+ continueFlagging+ _ -> do _ <- flagUnmatchedVar localEnv p improperListFlag + continueFlagging+ where continueFlagging = return $ Bool True ++-- |Flag a pattern variable that did not have any matching input+flagUnmatchedVar :: Env -> String -> Bool -> IOThrowsError LispVal+flagUnmatchedVar localEnv var improperListFlag = do+ _ <- defineVar localEnv var $ Nil "" -- Empty nil will signify the empty match+ defineNamespacedVar localEnv "unmatched nary pattern variable" var $ Bool $ improperListFlag++{- + - Utility function to insert a True flag to the proper trailing position of the DottedList indicator list+ - to indicate a dotted (improper) list in the pattern (fst) or input (snd)+ - -}+flagDottedLists :: [(Bool, Bool)] -> (Bool, Bool) -> Int -> [(Bool, Bool)]+flagDottedLists listFlags status lengthOfEllipsisIndex+ | length listFlags == lengthOfEllipsisIndex = listFlags ++ [status]+ -- Pad the original list with False flags, and append our status flags at the end+ | otherwise = listFlags ++ (replicate ((lengthOfEllipsisIndex) - (length listFlags)) (False, False)) ++ [status]++-- Get pair of list flags that are at depth of ellipIndex, or False if flags do not exist (means improper not flagged)+getListFlags :: [Int] -> [(Bool, Bool)] -> (Bool, Bool)+getListFlags elIndices flags + | length elIndices > 0 && length flags >= length elIndices = flags !! ((length elIndices) - 1)+ | otherwise = (False, False)++-- Check pattern against input to determine if there is a match+checkLocal :: Env -- Outer environment where this macro was called+ -> Env -- Local environment used to store temporary variables for macro processing+ -> 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 + -> LispVal -- Pattern to match+ -> 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+ if (ellipsisLevel) > 0 {- FUTURE: may be able to simplify both cases below by using a lambda function to store the 'save' actions -} @@ -269,8 +385,7 @@ -- Var is not bound in outer code; proceed then do -- Set variable in the local environment- _ <- addPatternVar isDefined $ Atom pattern- return $ Bool True+ addPatternVar isDefined ellipsisLevel ellipsisIndex pattern $ Atom pattern -- Var already bound in enclosing environment prior to evaluating macro. -- So... do not match it here. --@@ -282,8 +397,7 @@ -- Pattern/Input cannot match because input is not an atom _ -> return $ Bool False -- No literal identifier, just load up the var- _ -> do _ <- addPatternVar isDefined input- return $ Bool True+ _ -> addPatternVar isDefined ellipsisLevel ellipsisIndex pattern input -- -- Simple var, try to load up into macro env --@@ -316,7 +430,7 @@ Atom inpt -> do isLexicallyDefinedInput <- liftIO $ isBound outerEnv inpt -- Var defined in scope outside macro if isLexicallyDefinedInput- then do _ <- defineVar localEnv pattern (trace ("sec 4.3.2 for: " ++ inpt) (Nil inpt)) -- Var defined outside macro, flag as such for transform code+ 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@@ -325,228 +439,348 @@ return $ Bool True -} where- addPatternVar isDefined val = do- if isDefined- then do v <- getVar localEnv pattern- case v of- (List vs) -> setVar localEnv pattern (List $ vs ++ [val])- _ -> throwError $ Default "Unexpected error in checkLocal (Atom)"- else defineVar localEnv pattern (List [val])+ -- 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+ --+ addPatternVar isDefined ellipLevel ellipIndex pat val+ | isDefined = do v <- getVar localEnv pat+-- case (trace ("addPV pat = " ++ show pat ++ " v = " ++ show v) v) of+ case (v) of+ Nil _ -> do+ -- What's going on here is that the pattern var was found+ -- before but not set as a pattern variable because it+ -- was flagged as an unmatched var because input ran out+ -- before it was found. So we need to define it at this step.+ --+ -- This feels like a special case that should be handled+ -- in a more generic way. Anyhow, it seems to work fine for+ -- the moment, but we may need to revisit this down the road.+ _ <- initializePatternVar ellipLevel ellipIndex pat val+ return $ Bool False+ _ -> do _ <- setVar localEnv pat (Matches.setData v ellipIndex val)+ return $ Bool True+ | otherwise = do+ _ <- initializePatternVar ellipLevel ellipIndex pat val+ return $ Bool True -checkLocal outerEnv localEnv identifiers hasEllipsis pattern@(Vector _) input@(Vector _) =- loadLocal outerEnv localEnv identifiers pattern input False hasEllipsis+ -- Define a pattern variable that is seen for the first time+ initializePatternVar _ ellipIndex pat val = do+ let flags = getListFlags ellipIndex listFlags + _ <- defineVar localEnv pat (Matches.setData (List []) ellipIndex val)+ _ <- defineNamespacedVar localEnv "improper pattern" pat $ Bool $ fst flags+ defineNamespacedVar localEnv "improper input" pat $ Bool $ snd flags ------ TODO: both of the below patterns are handled incorrectly; see Issue #34.--- basically a pattern in the dotted tail position can match multiple times, similar (same?) as if an ellipsis was at the end of a list----checkLocal outerEnv localEnv identifiers hasEllipsis pattern@(DottedList _ _) input@(DottedList _ _) =- loadLocal outerEnv localEnv identifiers pattern input False hasEllipsis--- throwError $ BadSpecialForm "Test" input-checkLocal outerEnv localEnv identifiers hasEllipsis pattern@(DottedList ps p) input@(List (i : is)) = do- if (length ps) == (length is)- {- Lists are same length, implying elements in both should be the same.- Cast pair to a List for further processing -}- then loadLocal outerEnv localEnv identifiers (List $ ps ++ [p]) input False hasEllipsis- {- Idea here is that if we have a dotted list, the last component does not have to be provided- in the input. So in that case just fill in an empty list for the missing component. -}- else loadLocal outerEnv localEnv identifiers pattern (DottedList (i : is) (List [])) False hasEllipsis--- Issue #34 TODO: possible prototype code for this section - else loadLocal outerEnv localEnv identifiers (List $ ps ++ [p] ++ Atom "...") input False hasEllipsis-checkLocal outerEnv localEnv identifiers hasEllipsis pattern@(List _) input@(List _) =- loadLocal outerEnv localEnv identifiers pattern input False hasEllipsis+checkLocal outerEnv localEnv 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 -checkLocal _ _ _ _ _ _ = return $ Bool False+checkLocal outerEnv localEnv identifiers ellipsisLevel ellipsisIndex pattern@(DottedList _ _) input@(DottedList _ _) flags =+ loadLocal outerEnv localEnv identifiers pattern input ellipsisLevel ellipsisIndex flags -{- 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 -> Env -> Int -> LispVal -> LispVal -> LispVal -> IOThrowsError LispVal+checkLocal outerEnv localEnv identifiers ellipsisLevel ellipsisIndex (DottedList ps p) input@(List (_ : _)) flags = do+ loadLocal outerEnv localEnv 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 -{-- - Recursively transform a list- -- - Parameters:- -- - localEnv - Local variable environment- - ellipsisIndex - Zero-or-more match variables are stored as a list.- - This is the index into the current value to read from list- - result - Resultant value, must be a parameter as it mutates with each function call, so we pass it using CPS- - transform - The macro transformation, we read it out one atom at a time, and rewrite it into result- - ellipsisList - Temporarily holds value of the "outer" result while we process the- - zero-or-more match. Once that is complete we swap this value back into it's rightful place - -}-transformRule outerEnv localEnv ellipsisIndex (List result) transform@(List (List l : ts)) (List ellipsisList) = do- if macroElementMatchesMany transform+checkLocal _ _ _ _ _ _ _ _ = return $ Bool False++{- |Transform input by walking the tranform structure and creating a new structure+ with the same form, replacing identifiers in the tranform with those bound in localEnv -}+transformRule :: Env -- ^ Outer, enclosing environment+ -> Env -- ^ Environment local to the macro+ -> 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.+ -> LispVal -- ^ Resultant (transformed) value. + -- ^ Must be a parameter as it mutates with each transform call+ -> LispVal -- ^ The macro transformation, read out one atom at a time and rewritten to result+ -> IOThrowsError LispVal++-- Recursively transform a list+transformRule outerEnv localEnv 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 (ellipsisIndex + 1) (List []) (List l) (List result)- case curT of- Nil _ -> if ellipsisIndex == 0- -- First time through and no match ("zero" case). Use tail to move past the "..."- then transformRule outerEnv localEnv 0 (List $ result) (List $ tail ts) (List [])- -- Done with zero-or-more match, append intermediate results (ellipsisList) and move past the "..."- else transformRule outerEnv localEnv 0 (List $ ellipsisList ++ result) (List $ tail ts) (List [])- -- Dotted list transform returned during processing...- List [Nil _, List _] -> if ellipsisIndex == 0- -- First time through and no match ("zero" case). Use tail to move past the "..."- then transformRule outerEnv localEnv 0 (List $ result) (List $ tail ts) (List [])- -- Done with zero-or-more match, append intermediate results (ellipsisList) and move past the "..."- else transformRule outerEnv localEnv 0 (List $ result) (List $ tail ts) (List [])- List _ -> transformRule outerEnv localEnv (ellipsisIndex + 1) (List $ result ++ [curT]) transform (List ellipsisList)+ curT <- transformRule outerEnv localEnv 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 + 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 ellipsisIndex (List []) (List l) (List ellipsisList)+ lst <- transformRule outerEnv localEnv ellipsisLevel ellipsisIndex (List []) (List l) case lst of- List [Nil _, _] -> return lst- List _ -> transformRule outerEnv localEnv ellipsisIndex (List $ result ++ [lst]) (List ts) (List ellipsisList)+ List _ -> transformRule outerEnv localEnv ellipsisLevel ellipsisIndex (List $ result ++ [lst]) (List ts) Nil _ -> return lst- _ -> throwError $ BadSpecialForm "Macro transform error" $ List [lst, (List l), Number $ toInteger ellipsisIndex]+ _ -> throwError $ BadSpecialForm "Macro transform error" $ List [lst, (List l), Number $ toInteger ellipsisLevel] -transformRule outerEnv localEnv ellipsisIndex (List result) transform@(List ((Vector v) : ts)) (List ellipsisList) = do- if macroElementMatchesMany transform+-- 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+ 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 (ellipsisIndex + 1) (List []) (List $ elems v) (List result)+ curT <- transformRule outerEnv localEnv level idx (List []) (List $ elems v)+-- case (trace ("curT = " ++ show curT) curT) of case curT of- Nil _ -> if ellipsisIndex == 0- -- First time through and no match ("zero" case). Use tail to move past the "..."- then transformRule outerEnv localEnv 0 (List $ result) (List $ tail ts) (List [])- -- Done with zero-or-more match, append intermediate results (ellipsisList) and move past the "..."- else transformRule outerEnv localEnv 0 (List $ ellipsisList ++ result) (List $ tail ts) (List [])- List t -> transformRule outerEnv localEnv (ellipsisIndex + 1) (List $ result ++ [asVector t]) transform (List ellipsisList)+ Nil _ -> -- No match ("zero" case). Use tail to move past the "..."+ continueTransform outerEnv localEnv ellipsisLevel ellipsisIndex result $ tail ts+ List t -> transformRule outerEnv localEnv + 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 ellipsisIndex (List []) (List $ elems v) (List ellipsisList)+ else do lst <- transformRule outerEnv localEnv ellipsisLevel ellipsisIndex (List []) (List $ elems v) case lst of- List l -> do- transformRule outerEnv localEnv ellipsisIndex (List $ result ++ [asVector l]) (List ts) (List ellipsisList)+ List l -> transformRule outerEnv localEnv ellipsisLevel ellipsisIndex (List $ result ++ [asVector l]) (List ts) Nil _ -> return lst- _ -> throwError $ BadSpecialForm "transformRule: Macro transform error" $ List [(List ellipsisList), lst, (List [Vector v]), Number $ toInteger ellipsisIndex]+ _ -> throwError $ BadSpecialForm "transformRule: Macro transform error" $ List [lst, (List [Vector v]), Number $ toInteger ellipsisLevel] where asVector lst = (Vector $ (listArray (0, length lst - 1)) lst) -transformRule outerEnv localEnv ellipsisIndex (List result) transform@(List (dl@(DottedList _ _) : ts)) (List ellipsisList) = do- if macroElementMatchesMany transform+-- Recursively transform an improper list+transformRule outerEnv localEnv 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+ if nextHasEllipsis+-- 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 (ellipsisIndex + 1) (List []) (List [dl]) (List result)+ -- 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]) case curT of- Nil _ -> if ellipsisIndex == 0- -- First time through and no match ("zero" case). Use tail to move past the "..."- then transformRule outerEnv localEnv 0 (List $ result) (List $ tail ts) (List [])- -- Done with zero-or-more match, append intermediate results (ellipsisList) and move past the "..."- else transformRule outerEnv localEnv 0 (List $ ellipsisList ++ result) (List $ tail ts) (List [])- {- This case is here because we need to process individual components of the pair to determine- whether we are done with the match. It is similar to above but not exact... -}- List [Nil _, List _] -> if ellipsisIndex == 0- -- First time through and no match ("zero" case). Use tail to move past the "..."- then transformRule outerEnv localEnv 0 (List $ result) (List $ tail ts) (List [])- -- Done with zero-or-more match, append intermediate results (ellipsisList) and move past the "..."- else transformRule outerEnv localEnv 0 (List $ result) (List $ tail ts) (List [])- List t -> transformRule outerEnv localEnv (ellipsisIndex + 1) (List $ result ++ t) transform (List ellipsisList)+ Nil _ -> -- No match ("zero" case). Use tail to move past the "..."+ continueTransform outerEnv localEnv ellipsisLevel ellipsisIndex result $ tail ts + List t -> transformRule outerEnv localEnv + 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 ellipsisIndex (List []) (List [dl]) (List ellipsisList)+ else do lst <- transformDottedList outerEnv localEnv ellipsisLevel ellipsisIndex (List []) (List [dl]) case lst of- List [Nil _, List _] -> return lst- List l -> transformRule outerEnv localEnv ellipsisIndex (List $ result ++ l) (List ts) (List ellipsisList)+ List l -> transformRule outerEnv localEnv ellipsisLevel ellipsisIndex (List $ result ++ l) (List ts) Nil _ -> return lst- _ -> throwError $ BadSpecialForm "transformRule: Macro transform error" $ List [(List ellipsisList), lst, (List [dl]), Number $ toInteger ellipsisIndex]-+ _ -> 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 ellipsisIndex (List result) transform@(List (Atom a : ts)) unused = do- let hasEllipsis = macroElementMatchesMany transform+transformRule outerEnv localEnv ellipsisLevel ellipsisIndex (List result) transform@(List (Atom a : ts)) = do isDefined <- liftIO $ isBound localEnv a--- if (trace ("isDefined [" ++ show a ++ "]: " ++ show isDefined) hasEllipsis)- if (hasEllipsis)- then if isDefined+ if hasEllipsis+ then ellipsisHere isDefined+ else noEllipsis isDefined++ where+ -- 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) =+ case d of+ List lst -> if isImproperPattern && not isImproperInput+ then List $ lst ++ [List []]+ else List lst+ _ -> d+ appendNil d _ _ = d -- Should never be reached...++ loadNamespacedBool namespc = do+ isDef <- liftIO $ isNamespacedBound localEnv namespc a+ if isDef+ then getNamespacedVar localEnv namespc a+ else return $ Bool False++ hasEllipsis = macroElementMatchesMany transform+ ellipsisHere isDefined = do+ if isDefined then do - -- get var+ isImproperPattern <- loadNamespacedBool "improper pattern"+ isImproperInput <- loadNamespacedBool "improper input"+ -- Load variable and ensure it is a list var <- getVar localEnv a- -- ensure it is a list case var of -- add all elements of the list into result- List v -> transformRule outerEnv localEnv ellipsisIndex (List $ result ++ v) (List $ tail ts) unused+ List _ -> do case (appendNil (Matches.getData var ellipsisIndex) isImproperPattern isImproperInput) of+ List aa -> transformRule outerEnv localEnv ellipsisLevel ellipsisIndex (List $ result ++ aa) (List $ tail ts)+ _ -> -- No matches for var+ continueTransform outerEnv localEnv ellipsisLevel ellipsisIndex result $ tail ts+ {- TODO: Nil input -> do -- Var lexically defined outside of macro, load from there ----- TODO: this could be a problem, because we need to signal the end of the ... and do not want an infinite loop.--- but we want the lexical value as well. need to think about this in more detail to get a truly workable solution+-- 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 -}- v@(_) -> 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) else -- Matched 0 times, skip it- transformRule outerEnv localEnv ellipsisIndex (List result) (List $ tail ts) unused- else do t <- if isDefined- then do- var <- getVar localEnv a--- if ellipsisIndex > 0--(trace ("var = " ++ show a ++ " lex = " ++ isLexicallyDefinedVar) ellipsisIndex) > 0--- case (trace ("var = " ++ show var) var) of- case (var) of- Nil input -> do- v <- getVar outerEnv input- return v- _ -> if ellipsisIndex > 0--(trace ("var = " ++ show a) ellipsisIndex) > 0- then do case var of- List v -> if (length v) > (ellipsisIndex - 1)- then return $ v !! (ellipsisIndex - 1)- else return $ Nil ""- _ -> throwError $ Default "Unexpected error in transformRule"- else return var- else return $ Atom a--- case (trace ("t = " ++ show t) t) of- case t of- Nil _ -> return t- _ -> transformRule outerEnv localEnv ellipsisIndex (List $ result ++ [t]) (List ts) unused+ transformRule outerEnv localEnv 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+ --+ -- What's happening here is that the pattern was flagged because it was not matched in+ -- the pattern. We pick it up and in turn pass a special flag to the outer code (as t)+ -- so that it can finally be processed correctly.+ wasPair <- getNamespacedVar localEnv "unmatched nary pattern variable" a+ case wasPair of+ Bool True -> return $ Nil "var (pair) not defined in pattern"+ _ -> return $ Nil "var not defined in pattern"+ Nil input -> do v <- getVar outerEnv input+ return v+ List v -> do+ if ellipsisLevel > 0+ then -- Take all elements, instead of one-at-a-time+ return $ appendNil (Matches.getData var ellipsisIndex) + isImproperPattern + isImproperInput + else if length v > 0 + then return var -- Just return the elements directly, so all can be appended+ else return $ Nil "" -- A 0 match case, flag it to calling code+ _ -> if ellipsisLevel > 0+ then -- List req'd for 0-or-n match+ throwError $ Default "Unexpected error processing data in transformRule" + else return var+ else return $ Atom a+ case t of+ Nil "var not defined in pattern" -> + if ellipsisLevel > 0+ then return t+ else continueTransformWith result -- nary match in the pattern but used as list in transform; keep going+ Nil "var (pair) not defined in pattern" -> + if ellipsisLevel > 0+ then return t+ -- nary match in pattern as part of an improper list but used as list here; append the empty list+ else continueTransformWith $ result ++ [List []]+ Nil _ -> return t+ List l -> do+ -- What's going on here is that if the pattern was a dotted list but the transform is not, we+ -- need to "lift" the input up out of a list.+ if (eqVal isImproperPattern $ Bool True) && (eqVal isImproperInput $ Bool True)+ then continueTransformWith $ result ++ (buildImproperList l)+ else continueTransformWith $ result ++ [t]+ _ -> continueTransformWith $ result ++ [t]++ -- Transformed code should be an improper list, but may need to "promote" it to a proper list+ buildImproperList lst + | length lst > 1 = [DottedList (init lst) (last lst)]+ | otherwise = lst++ -- Continue calling into transformRule+ continueTransformWith results = + transformRule outerEnv + localEnv + ellipsisLevel + ellipsisIndex + (List $ results)+ (List ts)+ -- Transform anything else as itself...-transformRule outerEnv localEnv ellipsisIndex (List result) (List (t : ts)) (List ellipsisList) = do- transformRule outerEnv localEnv ellipsisIndex (List $ result ++ [t]) (List ts) (List ellipsisList)+transformRule outerEnv localEnv ellipsisLevel ellipsisIndex (List result) (List (t : ts)) = do+ transformRule outerEnv localEnv 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+transformRule _ localEnv _ _ _ (Atom transform) = do v <- getVar localEnv transform return v -- If transforming into a scalar, just return the transform directly... -- Not sure if this is strictly desirable, but does not break any tests so we'll go with it for now.-transformRule _ _ _ _ transform _ = do -- OLD CODE: result transform unused = do- return transform -- OLD CODE: throwError $ BadSpecialForm "An error occurred during macro transform" $ List [(Number $ toInteger ellipsisIndex), result, transform, unused]+transformRule _ _ _ _ _ transform = return transform -transformDottedList :: Env -> Env -> Int -> LispVal -> LispVal -> LispVal -> IOThrowsError LispVal-transformDottedList outerEnv localEnv ellipsisIndex (List result) (List (DottedList ds d : ts)) (List ellipsisList) = do- lsto <- transformRule outerEnv localEnv ellipsisIndex (List []) (List ds) (List ellipsisList)+-- | 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) case lsto of List lst -> do- r <- transformRule outerEnv localEnv ellipsisIndex (List []) (List [d]) (List ellipsisList)- case r of- -- Trailing symbol in the pattern may be neglected in the transform, so skip it...- List [List []] -> transformRule outerEnv localEnv ellipsisIndex (List $ result ++ [List lst]) (List ts) (List ellipsisList)- --- -- FUTURE: Issue #9 - the transform needs to be as follows:- --- {- - transform into a list if original input was a list - code is below but commented-out- - transform into a dotted list if original input was a dotted list -}- --- {- Could implement this by calling a new function on input (ds?) that goes through it and- looks up each atom that it finds, looking for its src. The src (or Nil?) would then be returned- and used here to determine what type of transform is used. -}- ---{- List [rst] -> transformRule localEnv ellipsisIndex (List $ result ++ [List $ lst ++ [rst]]) (List ts) (List ellipsisList)-List [rst] -> transformRule localEnv ellipsisIndex (List $ result ++ [DottedList lst rst]) (List ts) (List ellipsisList) -}- List [rst] -> do- src <- lookupPatternVarSrc localEnv $ List ds- case src of- String "pair" -> transformRule outerEnv localEnv ellipsisIndex (List $ result ++ [DottedList lst rst]) (List ts) (List ellipsisList)- _ -> transformRule outerEnv localEnv ellipsisIndex (List $ result ++ [List $ lst ++ [rst]]) (List ts) (List ellipsisList)- _ -> throwError $ BadSpecialForm "Macro transform error processing pair" $ DottedList ds d- Nil _ -> return $ List [Nil "", List ellipsisList]+ -- Similar logic to the parser is applied here, where+ -- results are transformed into either a list or pair depending upon whether+ -- they form a proper list+ --+ -- d is an n-ary match, per Issue #34+ r <- transformRule outerEnv localEnv + ellipsisLevel -- OK not to increment here, this is accounted for later on+ ellipsisIndex -- Same as above + (List []) + (List [d, Atom "..."])+ 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)+ Nil _ -> -- Same as above, no match for d, so skip it + transformRule outerEnv localEnv ellipsisLevel ellipsisIndex (List $ result ++ [List lst]) (List ts)+ List rst -> do+ transformRule outerEnv localEnv ellipsisLevel ellipsisIndex + (buildTransformedCode result lst rst) (List ts)+ _ -> throwError $ BadSpecialForm "Macro transform error processing pair" $ DottedList ds d+ Nil _ -> return $ Nil "" _ -> throwError $ BadSpecialForm "Macro transform error processing pair" $ DottedList ds d+ where + -- Transform code as either a proper or improper list depending upon the data+ -- These are rather crude methods of 'cons'-ing everything together... are all cases accounted for?+ buildTransformedCode results ps p = do + case p of+ [List []] -> List $ results ++ [List ps] -- Proper list has null list at the end+ [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+ -- Same concepts as above, but here we check the last entry of a list of elements+ -- FUTURE: should be able to use a common function to encapsulate logic above and below+ case last ls of+ List [] -> List $ results ++ [List $ ps ++ init ls]+ List lls -> List $ results ++ [List $ ps ++ (init ls) ++ lls]+ t -> List $ results ++ [DottedList (ps ++ init ls) t] + transformDottedList _ _ _ _ _ _ = throwError $ Default "Unexpected error in transformDottedList" --- Find an atom in a list; non-recursive (IE, a sub-list will not be inspected)+-- |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+ if not (null remaining)+ then transformRule outerEnv + localEnv + ellipsisLevel + ellipsisIndex + (List result) + (List $ remaining)+ else if length result > 0 + then return $ List result+ else if ellipsisLevel > 0 + then return $ Nil "" -- Nothing remains, no match+ else return $ List [] -- Nothing remains, return empty list++-- |Find an atom in a list; non-recursive (IE, a sub-list will not be inspected) findAtom :: LispVal -> LispVal -> IOThrowsError LispVal findAtom (Atom target) (List (Atom a : as)) = do if target == a@@ -555,75 +789,21 @@ findAtom _ (List (badtype : _)) = throwError $ TypeMismatch "symbol" badtype findAtom _ _ = return $ Bool False -{- Initialize any pattern variables as an empty list.- - That way a zero-match case can be identified later during transformation.- -- - Input:- - localEnv - Local environment that contains variables- - src - Input source, required because a pair in the pattern may be matched by either a list or a pair,- - and the transform needs to know this...- - identifiers - Literal identifiers that are transformed as themselves- - pattern - Pattern portion of the syntax rule - -}-initializePatternVars :: Env -> String -> LispVal -> LispVal -> IOThrowsError LispVal-initializePatternVars localEnv src identifiers pattern@(List _) = do- case pattern of- List (p : ps) -> do _ <- initializePatternVars localEnv src identifiers p- initializePatternVars localEnv src identifiers $ List ps- List [] -> return $ Bool True- _ -> return $ Bool True--initializePatternVars localEnv src identifiers (DottedList ps p) = do- _ <- initializePatternVars localEnv src identifiers $ List ps- initializePatternVars localEnv src identifiers p--initializePatternVars localEnv src identifiers (Vector v) = do- initializePatternVars localEnv src identifiers $ List $ elems v--initializePatternVars localEnv src identifiers (Atom pattern) =- {- FUTURE:- there is code to attempt to flag "src" here, but it is not- wire up correctly. In fact, the whole design here probably- needs to be rethinked. -}- do _ <- defineNamespacedVar localEnv "src" pattern $ String src- isDefined <- liftIO $ isBound localEnv pattern- found <- findAtom (Atom pattern) identifiers- case found of- (Bool False) -> if not isDefined -- Set variable in the local environment- then do- defineVar localEnv pattern (List [])- else do- return $ Bool True- -- Ignore identifiers since they are just passed along as-is- _ -> return $ Bool True--initializePatternVars _ _ _ _ =- return $ Bool True---- Find the first pattern var that reports being from a src, or False if none-lookupPatternVarSrc :: Env -> LispVal -> IOThrowsError LispVal-lookupPatternVarSrc localEnv pattern@(List _) = do- case pattern of- List (p : ps) -> do result <- lookupPatternVarSrc localEnv p- case result of- Bool False -> lookupPatternVarSrc localEnv $ List ps- _ -> return result- List [] -> return $ Bool False- _ -> return $ Bool False--lookupPatternVarSrc localEnv (DottedList ps p) = do- result <- lookupPatternVarSrc localEnv $ List ps- case result of- Bool False -> lookupPatternVarSrc localEnv p- _ -> return result--lookupPatternVarSrc localEnv (Vector v) = do- lookupPatternVarSrc localEnv $ List $ elems v--lookupPatternVarSrc localEnv (Atom pattern) =- do isDefined <- liftIO $ isNamespacedBound localEnv "src" pattern- if isDefined then getNamespacedVar localEnv "src" pattern- else return $ Bool False+-- |Increment ellipsis level based on whether a new ellipsis is present+calcEllipsisLevel :: Bool -> Int -> Int+calcEllipsisLevel nextHasEllipsis ellipsisLevel =+ if nextHasEllipsis then ellipsisLevel + 1+ else ellipsisLevel -lookupPatternVarSrc _ _ =- return $ Bool False+-- |Increment ellipsis index information based on given parameters+calcEllipsisIndex :: Bool -> Int -> [Int] -> [Int]+calcEllipsisIndex nextHasEllipsis ellipsisLevel ellipsisIndex =+ if nextHasEllipsis + then if (length ellipsisIndex == ellipsisLevel)+ -- This is not the first match, increment existing index+ then do+ let l = splitAt (ellipsisLevel - 1) ellipsisIndex+ (fst l) ++ [(head (snd l)) + 1]+ -- First input element that matches pattern; start at 0+ else ellipsisIndex ++ [0]+ else ellipsisIndex
+ hs-src/Language/Scheme/Macro/Matches.hs view
@@ -0,0 +1,167 @@+{- | +Module : Language.Scheme.Macro.Matches+Copyright : Justin Ethier+Licence : MIT (see LICENSE in the distribution)++Maintainer : github.com/justinethier+Stability : experimental+Portability : portable++husk scheme interpreter++A lightweight dialect of R5RS scheme.++This module contains utility functions used to support macro processing,+by storing and/or manipulating data involving 0-or-many matches.+-}+module Language.Scheme.Macro.Matches (getData, setData) where+import Language.Scheme.Types+import Control.Exception+--import Debug.Trace++-- |Create a nested list+_create :: Int -- ^ Number of nesting levels+ -> LispVal -- ^ Empty nested list+_create level + | level < 1 = Nil "" -- Error+ | level == 1 = List []+ | otherwise = List [_create $ level - 1]++-- |Fill any empty "holes" in a list from the beginning to the given length+--+-- The problem here is how to handle case when a requested insertion leaves "holes".+--+-- For example, in a 2-level nested list: ((1)) we have data as pos 0 but have none at pos 1.+-- If the code then tries to add an element 2 at pos 2 we should end up with:+--+-- ((1) () (2))+--+fill :: [LispVal] -> Int -> [LispVal]+fill l len + | length l < len = fill (l ++ [List []]) len+ | otherwise = l++-- |Get an element at given location in the nested list+getData :: LispVal -- ^ The nested list to read from+ -> [Int] -- ^ Location to read an element from, all numbers are 0-based+ -> LispVal -- ^ Value read, or "Nil" if none+getData (List lData) (i:is) = do+ if length lData < i+ then Nil "" -- Error: there are not enough elements in the list+ else do+ let lst = drop i lData+ if length lst > 0+ then getData (head lst) is+ else Nil "" -- Error: not enough elements in list+getData val [] = val -- Base case: we have found the requested element+getData val _ = val -- Should never be reached, just give up and return val ++-- |Add an element to the given nested list+setData :: LispVal -- ^ The nested list to modify+ -> [Int] -- ^ Location to insert the new element, from top-most -> leaf + -- (EG: [1, 2] means add to the second top-most list, at its 3rd position)+ -> LispVal -- ^ Value to insert + -> LispVal -- ^ Resulant list+setData (List lData) (i:is) val = do+ -- Fill "holes" as long as they are not at the leaves.+ --+ -- This is because, when a match occurs it happens 0 or more times.+ -- Therefore it is not possible (at the leaves) for a match to occur where that match is not+ -- placed at the end of the list. For example, if the pattern is:+ --+ -- a ...+ --+ -- And the input is:+ --+ -- 1 2 3+ --+ -- Then we always store the first match in position 0, second in 1, etc. There are no holes+ -- in this case because there is never a reason to skip any of these positions.+ if length is > 0 && length lData < i + 1 + then set $ fill lData $ i + 1+ else set lData++ where ++-- set listData = case (snd (trace ("content = " ++ show content) content)) of+ set listData = do+ let content = splitAt i listData+ case (snd content) of+ [] -> List $ listData ++ [val]+ [c] -> if length is < 1+ then List $ (fst content) ++ [val] ++ [c] -- Base case - Requested pos must be one less than c+ else List $ (fst content) ++ [setData c is val]+ (c:cs) -> if length is < 1+ then List $ (fst content) ++ [val] ++ [c] ++ (cs) -- Base case - Requested pos must be one less than c+ else List $ (fst content) ++ [setData c is val] ++ (cs) ++setData _ _ val = val -- Should never be reached; just return val++-- |Compare actual input with expected+_cmp :: LispVal -> LispVal -> IO ()+_cmp input expected = do+ putStrLn $ show input+ putStrLn $ show $ assert (eqVal expected input) input++-- |Run this function to test the above code+_test :: IO ()+_test = do+ _cmp (setData (List [Number 1, Number 2, Number 3, Number 4]) [4] (Number 5)) + (List [Number 1, Number 2, Number 3, Number 4, Number 5])++ _cmp (setData (List [Number 1, Number 2, Number 3, Number 4]) [1] (Number 5)) + (List [Number 1, Number 5, Number 2, Number 3, Number 4])++ _cmp (setData (List [List [Number 1, Number 2], List [Number 3, Number 4, Number 5]]) [1, 3] (Number 6)) + (List [List [Number 1, Number 2], List [Number 3, Number 4, Number 5, Number 6]])++ _cmp (setData (List [List [Number 1, Number 2], List [Number 3, Number 4, Number 5]]) [1, 2] (Number 6)) + (List [List [Number 1, Number 2], List [Number 3, Number 4, Number 6, Number 5]])++ _cmp (setData (List [List [Number 1, Number 2], List [Number 3, Number 4, Number 5]]) [0, 2] (Number 6)) + (List [List [Number 1, Number 2, Number 6], List [Number 3, Number 4, Number 5]])++ let a = _create 2+ _cmp a + (List [List []])++ let b = setData a [0, 0] $ Atom "test"+ _cmp b (List [List [Atom "test"]])++ let c = setData b [0, 1] $ Atom "test2"+ _cmp c (List [List [Atom "test", Atom "test2"]])+++-- An invalid test case because it attempts to initialize a leaf by adding at a non-zero leaf position.+--_cmp (setData (List []) [0, 1, 2] $ Atom "test") +-- (List [List[List [], List[List [], List[], Atom "test"]]])+-- A correct test is below:+ _cmp (setData (List []) [0, 1, 0] $ Atom "test") + (List [List[List [], List[Atom "test"]]])++ -- Illustrates an important point, that if we are adding into + -- a 'hole', we need to create a list there first+ let cc = setData b [1, 0] $ Atom "test2"+ _cmp cc (List [List [Atom "test"], List [Atom "test2"]])++ let cc2 = setData b [1, 4] $ Atom "test2"+ _cmp cc2 (List [List [Atom "test"], List [Atom "test2"]])++ let cc3 = setData b [4, 0] $ Atom "test2"+ _cmp cc3 (List [List [Atom "test"], List [], List [], List [], List [Atom "test2"]])++ _cmp (setData (List []) [4, 0] (Number 5)) + (List [List [], List [], List [], List [], List [Number 5]])++ _cmp (getData (List [List [List [], List [Number 1, Number 2, Number 3, Number 4]]]) [0, 1, 2]) + (Number 3)++-- _cmp (getData (List [List [List [], List [Number 1, Number 2, Number 3, Number 4]]]) [0, 1, 20]) +-- (Nil "")++ _cmp (getData (List [List [List [], List [Atom "1", Number 2, Number 3, Number 4]]]) [0, 1, 0]) + (Atom "1")++ -- Real world case, we would like to take the list (all leaves) at [0, 1]+ _cmp (getData (List [List [List [], List [Atom "1", Number 2, Number 3, Number 4]]]) [0, 1]) + (List [Atom "1", Number 2, Number 3, Number 4])
hs-src/Language/Scheme/Parser.hs view
@@ -214,7 +214,28 @@ parseDottedList = do phead <- endBy parseExpr whiteSpace ptail <- dot >> parseExpr --char '.' >> whiteSpace >> parseExpr- return $ DottedList phead ptail+-- return $ DottedList phead ptail+ case ptail of+ DottedList ls l -> return $ DottedList (phead ++ ls) l + -- Issue #41+ -- Improper lists are tricky because if an improper list ends in a proper list, then it becomes proper as well.+ -- The following cases handle that, as well as preserving necessary functionality when appropriate, such as for+ -- unquoting.+ --+ -- FUTURE: I am not sure if this is complete, in fact the "unquote" seems like it could either be incorrect or+ -- one special case among others. Anyway, for the 3.3 release this is good enough to pass all test+ -- cases. It will be revisited later if necessary.+ --+ List (Atom "unquote" : _) -> return $ DottedList phead ptail + List ls -> return $ List $ phead ++ ls+ {- Regarding above, see http://community.schemewiki.org/?scheme-faq-language#dottedapp+ + Note, however, that most Schemes expand literal lists occurring in function applications, + e.g. (foo bar . (1 2 3)) is expanded into (foo bar 1 2 3) by the reader. It is not entirely + clear whether this is a consequence of the standard - the notation is not part of the R5RS + grammar but there is strong evidence to suggest a Scheme implementation cannot comply with + all of R5RS without performing this transformation. -}+ _ -> return $ DottedList phead ptail parseQuoted :: Parser LispVal parseQuoted = do
hs-src/shell.hs view
@@ -67,7 +67,7 @@ putStrLn " | | | | |_| \\__ \\ < /// \\\\\\ \\__ \\ (__| | | | __/ | | | | | __/ " putStrLn " |_| |_|\\__,_|___/_|\\_\\ /// \\\\\\ |___/\\___|_| |_|\\___|_| |_| |_|\\___| " putStrLn " "- putStrLn " husk Scheme Interpreter Version 3.2.1 "+ putStrLn " husk Scheme Interpreter Version 3.3 " 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.2.1+Version: 3.3 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,@@ -12,34 +12,38 @@ Cabal-Version: >= 1.4 Build-Type: Simple Category: Compilers/Interpreters, Language-Tested-with: GHC == 6.12.3, GHC == 6.10.4+Tested-with: GHC == 7.0.2, GHC == 6.12.3, GHC == 6.10.4 Extra-Source-Files: README.markdown LICENSE Data-Files: stdlib.scm Library- Build-Depends: base >= 2.0 && < 5, array, containers, haskeline, haskell98, mtl, parsec, directory, ghc, ghc-paths+ Build-Depends: base >= 2.0 && < 5, array, containers, haskeline, haskell98 < 2, mtl, parsec, directory, ghc, ghc-paths Extensions: ExistentialQuantification CPP CPP Hs-Source-Dirs: hs-src Exposed-Modules: Language.Scheme.Core Language.Scheme.Types Language.Scheme.Variables Language.Scheme.Plugins.CPUTime- Other-Modules: Language.Scheme.Macro+ Other-Modules: Language.Scheme.FFI+ Language.Scheme.Macro+ Language.Scheme.Macro.Matches Language.Scheme.Numerical Language.Scheme.Parser Language.Scheme.Primitives Executable huski- Build-Depends: base >= 2.0 && < 5, array, containers, haskeline, haskell98, mtl, parsec, directory, ghc, ghc-paths+ Build-Depends: base >= 2.0 && < 5, array, containers, haskeline, haskell98 < 2, mtl, parsec, directory, ghc, ghc-paths Extensions: ExistentialQuantification CPP CPP Main-is: shell.hs Hs-Source-Dirs: hs-src Other-Modules: Language.Scheme.Core+ Language.Scheme.FFI Language.Scheme.Types Language.Scheme.Variables Language.Scheme.Macro+ Language.Scheme.Macro.Matches Language.Scheme.Numerical Language.Scheme.Parser Language.Scheme.Primitives
stdlib.scm view
@@ -43,7 +43,7 @@ (define (list . objs) objs) (define (id obj) obj) -(define (flip func) (lambda (arg1 arg2) (func arg2 arg1)))+(define (flip func) (lambda (arg1 arg2) (func arg1 arg2))) (define (curry func arg1) (lambda (arg) (apply func (cons arg1 (list arg))))) (define (compose f g) (lambda (arg) (f (apply g arg))))@@ -56,7 +56,7 @@ (define (foldl func accum lst) (if (null? lst) accum- (foldl func (func accum (car lst)) (cdr lst))))+ (foldl func (func (car lst) accum) (cdr lst)))) (define fold foldl) (define reduce fold)@@ -99,7 +99,7 @@ (define (odd? num) (= (modulo num 2) 1)) (define (even? num) (= (modulo num 2) 0)) -(define (length lst) (fold (lambda (x y) (+ x 1)) 0 lst))+(define (length lst) (fold (lambda (x y) (+ y 1)) 0 lst)) (define (reverse lst) (fold (flip cons) '() lst)) ; cond@@ -177,7 +177,7 @@ (define (memv obj lst) (my-mem-helper obj lst eqv?)) (define (member obj lst) (my-mem-helper obj lst equal?)) -(define (mem-helper pred op) (lambda (acc next) (if (and (not acc) (pred (op next))) next acc)))+(define (mem-helper pred op) (lambda (next acc) (if (and (not acc) (pred (op next))) next acc))) (define (assq obj alist) (fold (mem-helper (curry eq? obj) car) #f alist)) (define (assv obj alist) (fold (mem-helper (curry eqv? obj) car) #f alist)) (define (assoc obj alist) (fold (mem-helper (curry equal? obj) car) #f alist))@@ -241,21 +241,29 @@ (let* ((vars vals) ...) body))))) - ; Iteration - do (define-syntax do (syntax-rules ()- ((_ ((var init . step) ...)- (test expr ...) - command ...)- (let loop ((var init) ...)- (if test- (begin expr ...)- (begin (begin command ...)- (loop - (if (null? (cdr (list var . step))) - (car (list var . step))- (cadr (list var . step))) ...)))))))+ ((do ((var init step ...) ...)+ (test expr ...)+ command ...)+ (letrec+ ((loop+ (lambda (var ...)+ (if test+ (begin+ (if #f #f)+ expr ...)+ (begin+ command+ ...+ (loop (do "step" var step ...)+ ...))))))+ (loop init ...)))+ ((do "step" x)+ x)+ ((do "step" x y)+ y))) ; Delayed evaluation functions (define force