husk-scheme 3.12 → 3.13
raw patch · 46 files changed
+1997/−1510 lines, 46 files
Files
- ChangeLog.markdown +14/−0
- README.markdown +0/−1
- hs-src/Compiler/huskc.hs +29/−20
- hs-src/Interpreter/shell.hs +17/−9
- hs-src/Language/Scheme/Compiler.hs +51/−2
- hs-src/Language/Scheme/Compiler/Libraries.hs +3/−1
- hs-src/Language/Scheme/Compiler/Types.hs +14/−8
- hs-src/Language/Scheme/Core.hs +108/−256
- hs-src/Language/Scheme/Environments.hs +255/−0
- hs-src/Language/Scheme/Libraries.hs +23/−21
- hs-src/Language/Scheme/Macro.hs +166/−132
- hs-src/Language/Scheme/Primitives.hs +82/−2
- hs-src/Language/Scheme/Types.hs +5/−3
- hs-src/Language/Scheme/Variables.hs +38/−2
- husk-scheme.cabal +3/−2
- lib/core.scm +557/−0
- lib/cxr.scm +30/−0
- lib/lazy.scm +25/−0
- lib/modules.scm +6/−0
- lib/scheme/base.sld +256/−5
- lib/scheme/case-lambda.sld +43/−0
- lib/scheme/char.sld +35/−0
- lib/scheme/complex.sld +19/−0
- lib/scheme/cxr.sld +37/−0
- lib/scheme/eval.sld +19/−0
- lib/scheme/file.sld +23/−0
- lib/scheme/inexact.sld +25/−0
- lib/scheme/lazy.sld +19/−0
- lib/scheme/load.sld +12/−0
- lib/scheme/process-context.sld +20/−0
- lib/scheme/r5rs.sld +18/−0
- lib/scheme/r5rs/base.sld +0/−256
- lib/scheme/r5rs/char.sld +0/−38
- lib/scheme/r5rs/complex.sld +0/−22
- lib/scheme/r5rs/cxr.sld +0/−40
- lib/scheme/r5rs/eval.sld +0/−20
- lib/scheme/r5rs/file.sld +0/−26
- lib/scheme/r5rs/inexact.sld +0/−28
- lib/scheme/r5rs/lazy.sld +0/−21
- lib/scheme/r5rs/load.sld +0/−15
- lib/scheme/r5rs/read.sld +0/−15
- lib/scheme/r5rs/write.sld +0/−20
- lib/scheme/read.sld +12/−0
- lib/scheme/repl.sld +13/−0
- lib/scheme/write.sld +17/−0
- lib/stdlib.scm +3/−545
ChangeLog.markdown view
@@ -1,4 +1,18 @@ +v3.13+--------++- Added the command line flag `--revision 7` (or `-r7` for short) to allow huski and huskc to start in R<sup>7</sup>RS mode.+- Added most of the standard R<sup>7</sup>RS libraries: `(scheme base)`, `(scheme char)`, etc.+- Extended syntax-rules to allow another identifier to be used to specify the ellipsis symbol, per R<sup>7</sup>RS. For example, `:::` could be used instead:++ (define-syntax and+ (syntax-rules ::: ()+ ((and test1 test2 :::)+ (if test1 (and test2 :::) #f))))++- Added the following functions from R<sup>7</sup>RS: `make-list` , `list-copy` , `list-set!` , `vector-copy` , `vector-map` , `vector-for-each` , `vector-append` , `string-map` , `string-for-each` , `string->vector` , `vector->string` , `vector-copy!` , `string-copy!` + v3.12 --------
README.markdown view
@@ -33,7 +33,6 @@ (lambda () ...) huski> (hello) world- huski> husk has been tested on Windows, Linux, and FreeBSD.
hs-src/Compiler/huskc.hs view
@@ -31,7 +31,7 @@ args <- getArgs let (actions, nonOpts, msgs) = getOpt Permute options args opts <- foldl (>>=) (return defaultOptions) actions- let Options {optOutput = output, optLibs = lib, optDynamic = dynamic, optCustomOptions = extra} = opts+ let Options {optOutput = output, optLibs = lib, optDynamic = dynamic, optCustomOptions = extra, optSchemeRev = langrev} = opts if null nonOpts then showUsage@@ -44,7 +44,8 @@ extraOpts = case extra of Just args -> args Nothing -> ""- process inFile outHaskell outExec lib dynamic extraOpts+-- TODO: pass language revision+ process inFile outHaskell outExec lib dynamic extraOpts langrev -- -- For an explanation of the command line options code, see:@@ -56,7 +57,8 @@ optOutput :: Maybe String, -- Executable file to write optLibs :: Bool, -- Debug flag, whether to compile standard libraries optDynamic :: Bool, -- Flag for dynamic linking of compiled executable- optCustomOptions :: Maybe String -- Custom options to ghc+ optCustomOptions :: Maybe String, -- Custom options to ghc+ optSchemeRev :: String -- Scheme Language version } -- |Default values for the command line options@@ -65,12 +67,14 @@ optOutput = Nothing, optLibs = True, optDynamic = False,- optCustomOptions = Nothing + optCustomOptions = Nothing, + optSchemeRev = "5" } -- |Command line options options :: [OptDescr (Options -> IO Options)] options = [+ Option ['r'] ["revision"] (ReqArg writeRxRSVersion "Scheme") "scheme RxRS version", Option ['V'] ["version"] (NoArg showVersion) "show version number", Option ['h', '?'] ["help"] (NoArg showHelp) "show usage information", Option ['o'] ["output"] (ReqArg writeExec "FILE") "output file to write",@@ -81,6 +85,8 @@ Option [] ["nolibs"] (NoArg getNoLibs) "a DEBUG option to use interpreted libraries instead of compiling them" ] +writeRxRSVersion arg opt = return opt { optSchemeRev = arg }+ -- |Determine executable file to write. -- This version just takes a name from the command line option writeExec arg opt = return opt { optOutput = Just arg }@@ -102,9 +108,15 @@ showHelp _ = do putStrLn "Usage: huskc [options] file" putStrLn ""- putStrLn "Options:"+ putStrLn " Options:"+ putStrLn "" putStrLn " --help Display this information" putStrLn " --version Display husk version information"+ putStrLn " --revision rev Specify the scheme revision to use:"+ putStrLn ""+ putStrLn " 5 - r5rs (default)"+ putStrLn " 7 - r7rs small"+ putStrLn "" putStrLn " --output filename Write executable to the given filename" putStrLn " --dynamic Use dynamic Haskell libraries, if available" putStrLn " (Requires libraries built via --enable-shared)"@@ -127,14 +139,11 @@ exitWith ExitSuccess -- |High level code to compile the given file-process :: String -> String -> String -> Bool -> Bool -> String -> IO ()-process inFile outHaskell outExec libs dynamic extraArgs = do----- TODO: how to integrate r5rsEnv and libraries?--- env <- Language.Scheme.Core.r5rsEnv'+process :: String -> String -> String -> Bool -> Bool -> String -> String -> IO ()+process inFile outHaskell outExec libs dynamic extraArgs langrev = do+ env <- case langrev of+ "7" -> Language.Scheme.Core.r7rsEnv'+ _ -> Language.Scheme.Core.r5rsEnv' stdlib <- getDataFileName "lib/stdlib.scm" srfi55 <- getDataFileName "lib/srfi/srfi-55.scm" -- (require-extension) @@ -142,14 +151,14 @@ then Just stdlib else Nothing - result <- (Language.Scheme.Core.runIOThrows $ liftM show $ compileSchemeFile env stdlibArg srfi55 inFile outHaskell)+ result <- (Language.Scheme.Core.runIOThrows $ liftM show $ compileSchemeFile env stdlibArg srfi55 inFile outHaskell langrev) case result of Just errMsg -> putStrLn errMsg _ -> compileHaskellFile outHaskell outExec dynamic extraArgs -- |Compile a scheme file to haskell-compileSchemeFile :: Env -> Maybe String -> String -> String -> String -> IOThrowsError LispVal-compileSchemeFile env stdlib srfi55 filename outHaskell = do+compileSchemeFile :: Env -> Maybe String -> String -> String -> String -> String -> IOThrowsError LispVal+compileSchemeFile env stdlib srfi55 filename outHaskell langrev = do let conv :: LispVal -> String conv (String s) = s compileLibraries = case stdlib of@@ -159,9 +168,8 @@ -- TODO: clean this up later --moduleFile <- liftIO $ getDataFileName "lib/modules.scm" - (String nextFunc, libsC, libSrfi55C, libModules) <- case stdlib of- Nothing -> return (String "run", [], [], [])- Just stdlib' -> do+ (String nextFunc, libsC, libSrfi55C, libModules) <- case (stdlib, langrev) of+ (Just stdlib', "5") -> do -- TODO: it is only temporary to compile the standard library each time. It should be -- precompiled and just added during the ghc compilation libsC <- compileLisp env stdlib' "run" (Just "exec55")@@ -169,6 +177,7 @@ --libModules <- compileLisp env moduleFile "exec55_2" (Just "exec55_3") liftIO $ Language.Scheme.Core.registerExtensions env getDataFileName return (String "exec", libsC, libSrfi55C, []) --libModules)+ (_, _) -> return (String "run", [], [], []) -- Initialize the compiler module and begin _ <- initializeCompiler env@@ -183,7 +192,7 @@ _ <- liftIO $ writeList outH headerModule _ <- liftIO $ writeList outH $ map (\mod -> "import " ++ mod ++ " ") $ headerImports ++ moreHeaderImports filepath <- liftIO $ getDataFileName ""- _ <- liftIO $ writeList outH $ header filepath compileLibraries+ _ <- liftIO $ writeList outH $ header filepath compileLibraries langrev _ <- liftIO $ case compileLibraries of True -> do _ <- writeList outH $ map show libsC
hs-src/Interpreter/shell.hs view
@@ -74,13 +74,12 @@ putStrLn "" putStrLn " Options may be any of the following:" putStrLn ""- putStrLn " -h -? --help Display this information"--- TODO: specify scheme rev via command line--- putStrLn " -r --revision Specify the scheme revision to use:"--- putStrLn ""--- putStrLn " 5 - r5rs (default)"--- putStrLn " 7 - r7rs small"+ putStrLn " --help Display this information"+ putStrLn " --revision rev Specify the scheme revision to use:" putStrLn ""+ putStrLn " 5 - r5rs (default)"+ putStrLn " 7 - r7rs small"+ putStrLn "" exitWith ExitSuccess --@@ -92,8 +91,11 @@ -- |Execute a single scheme file from the command line runOne :: String -> [String] -> IO ()-runOne _ args = do- env <- LSC.r5rsEnv >>= flip LSV.extendEnv+runOne "7" args = runOneWenv LSC.r7rsEnv args+runOne _ args = runOneWenv LSC.r5rsEnv args++runOneWenv initEnv args = do+ env <- initEnv >>= flip LSV.extendEnv [((LSV.varNamespace, "args"), List $ map String $ drop 1 args)] @@ -114,9 +116,15 @@ -- |Start the REPL (interactive interpreter) runRepl :: String -> IO ()+runRepl "7" = do+ env <- liftIO $ LSC.r7rsEnv+ runReplWenv env runRepl _ = do- env <- LSC.r5rsEnv+ env <- liftIO $ LSC.r5rsEnv + runReplWenv env +runReplWenv :: Env -> IO ()+runReplWenv env = do let settings = HL.Settings (completeScheme env) Nothing True HL.runInputT settings (loop env) where
hs-src/Language/Scheme/Compiler.hs view
@@ -267,6 +267,22 @@ return $ [createAstFunc copts compFunc]) compile env lisp@(List [Atom "define-syntax", Atom keyword, + (List (Atom "syntax-rules" : Atom ellipsis : (List identifiers : rules)))]) copts = do+ compileSpecialFormBody env lisp copts (\ _ -> do+ let idStr = asts2Str identifiers+ ruleStr = asts2Str rules+ + -- Make macro available at compile time+ _ <- defineNamespacedVar env macroNamespace keyword $ + Syntax (Just env) Nothing False ellipsis identifiers rules+ + -- And load it at runtime as well+ -- Env should be identical to the one loaded at compile time...+ compileScalar + (" defineNamespacedVar env macroNamespace \"" ++ keyword ++ + "\" $ Syntax (Just env) Nothing False \"" ++ ellipsis ++ "\" " ++ idStr ++ " " ++ ruleStr) copts)++compile env lisp@(List [Atom "define-syntax", Atom keyword, (List (Atom "syntax-rules" : (List identifiers : rules)))]) copts = do compileSpecialFormBody env lisp copts (\ _ -> do let idStr = asts2Str identifiers@@ -274,13 +290,13 @@ -- Make macro available at compile time _ <- defineNamespacedVar env macroNamespace keyword $ - Syntax (Just env) Nothing False identifiers rules+ Syntax (Just env) Nothing False "..." identifiers rules -- And load it at runtime as well -- Env should be identical to the one loaded at compile time... compileScalar (" defineNamespacedVar env macroNamespace \"" ++ keyword ++ - "\" $ Syntax (Just env) Nothing False " ++ idStr ++ " " ++ ruleStr) copts)+ "\" $ Syntax (Just env) Nothing False \"...\" " ++ idStr ++ " " ++ ruleStr) copts) compile env ast@(List [Atom "if", predic, conseq]) copts = compileSpecialFormBody env ast copts (\ _ -> do@@ -634,6 +650,39 @@ compile env ast@(List (Atom "set-cdr!" : args)) copts = do compileSpecialFormBody env ast copts (\ nextFunc -> do f <- compileSpecialForm "set-cdr!" ("throwError $ NumArgs 2 $ [String \"" ++ + (show args) ++ "\"]") copts+ return [f])++compile env ast@(List [Atom "list-set!", Atom var, i, object]) copts = do+ compileSpecialFormBody env ast copts (\ nextFunc -> do+ Atom symCompiledIdx <- _gensym "listSetIdx"+ Atom symCompiledObj <- _gensym "listSetObj"+ Atom symUpdateVec <- _gensym "listSetUpdate"+ Atom symIdxWrapper <- _gensym "listSetIdxWrapper"+ + -- Entry point that allows this form to be redefined+ entryPt <- compileSpecialFormEntryPoint "list-set!" symCompiledIdx copts+ -- Compile index, then use a wrapper to pass it as an arg while compiling obj+ compiledIdx <- compileExpr env i symCompiledIdx (Just symIdxWrapper) + compiledIdxWrapper <- return $ AstFunction symIdxWrapper " env cont idx _ " [+ AstValue $ " " ++ symCompiledObj ++ " env (makeCPSWArgs env cont " ++ symUpdateVec ++ " [idx]) (Nil \"\") Nothing " ]+ compiledObj <- compileExpr env object symCompiledObj Nothing+ -- Do actual update+ compiledUpdate <- return $ AstFunction symUpdateVec " env cont obj (Just [idx]) " [+ AstValue $ " vec <- getVar env \"" ++ var ++ "\"",+ AstValue $ " result <- updateList vec idx obj >>= updateObject env \"" ++ var ++ "\"",+ createAstCont copts "result" ""]+ + return $ [entryPt, compiledIdxWrapper, compiledUpdate] ++ compiledIdx ++ compiledObj)++compile env ast@(List [Atom "list-set!", nonvar, _, _]) copts = do + compileSpecialFormBody env ast copts (\ nextFunc -> do+ f <- compileSpecialForm "list-set!" ("throwError $ TypeMismatch \"variable\"" +++ " $ String \"" ++ (show nonvar) ++ "\"") copts+ return [f])+compile env ast@(List (Atom "list-set!" : args)) copts = do+ compileSpecialFormBody env ast copts (\ nextFunc -> do+ f <- compileSpecialForm "list-set!" ("throwError $ NumArgs 3 $ [String \"" ++ (show args) ++ "\"]") copts return [f])
hs-src/Language/Scheme/Compiler/Libraries.hs view
@@ -111,9 +111,11 @@ -- TODO: This really should be handled by the add-module! that is executed during -- module initialization, instead of having a special case here AstValue $ " r5 <- liftIO $ r5rsEnv\n let value = LispEnv r5"+ codeToGetFromEnv (List [Atom "scheme"]) _ = do+ -- hack to compile-in full env for the (scheme) import by r7rs+ AstValue $ " r7 <- liftIO $ r7rsEnv\n let value = LispEnv r7" codeToGetFromEnv (List [Atom "scheme", Atom "time", Atom "posix"]) _ = do AstValue $ " e <- liftIO $ r7rsTimeEnv\n let value = LispEnv e"- codeToGetFromEnv name [] = do -- No code was generated because module was loaded previously, so retrieve -- it from runtime memory
hs-src/Language/Scheme/Compiler/Types.hs view
@@ -206,11 +206,19 @@ -- |Block of code used in the header of a Haskell program -- generated by the compiler.-header :: String -> Bool -> [String]-header filepath useCompiledLibs = do+header :: String -> Bool -> String -> [String]+header filepath useCompiledLibs langRev = do let env = if useCompiledLibs then "primitiveBindings"- else "r5rsEnv"+ else case langRev of+ "7" -> "r7rsEnv"+ _ -> "r5rsEnv"+ initSrfi55 = + case langRev of+ "7" -> []+ _ -> [ "exec55_3 env cont _ _ = do "+ , " liftIO $ registerExtensions env getDataFileName' "+ , " continueEval env (makeCPS env cont exec) (Nil \"\")"] [ " " , "-- |Get variable at runtime " , "getRTVar env var = do " @@ -232,11 +240,9 @@ , " " , "getDataFileName' :: FilePath -> IO FilePath " , "getDataFileName' name = return $ \"" ++ (Language.Scheme.Util.escapeBackslashes filepath) ++ "\" ++ name "- , " "- , "exec55_3 env cont _ _ = do "- , " liftIO $ registerExtensions env getDataFileName' "- , " continueEval env (makeCPS env cont exec) (Nil \"\")"- , " "+ , " "]+ ++ initSrfi55 ++ + [ " " , "main :: IO () " , "main = do " , " env <- " ++ env ++ " "
hs-src/Language/Scheme/Core.hs view
@@ -28,16 +28,19 @@ , primitiveBindings , r5rsEnv , r5rsEnv'- -- , r7rsEnv+ , r7rsEnv+ , r7rsEnv' , r7rsTimeEnv , version -- * Utility functions , findFileOrLib , getDataFileFullPath+ , replaceAtIndex , registerExtensions , showBanner , showLispError , substr+ , updateList , updateVector , updateByteVector -- * Internal use only@@ -47,6 +50,7 @@ #ifdef UseFfi import qualified Language.Scheme.FFI #endif+import Language.Scheme.Environments import Language.Scheme.Libraries import qualified Language.Scheme.Macro import Language.Scheme.Numerical@@ -67,7 +71,7 @@ -- |husk version number version :: String-version = "3.12"+version = "3.13" -- |A utility function to display the husk console banner showBanner :: IO ()@@ -404,6 +408,16 @@ continueEval env cont $ Nil "" eval env cont args@(List [Atom "define-syntax", Atom keyword, + (List (Atom "syntax-rules" : Atom ellipsis : (List identifiers : rules)))]) = do+ bound <- liftIO $ isRecBound env "define-syntax"+ if bound+ then prepareApply env cont args -- if bound to a variable in this scope; call into it+ else do + _ <- defineNamespacedVar env macroNamespace keyword $ + Syntax (Just env) Nothing False ellipsis identifiers rules+ continueEval env cont $ Nil "" ++eval env cont args@(List [Atom "define-syntax", Atom keyword, (List (Atom "syntax-rules" : (List identifiers : rules)))]) = do bound <- liftIO $ isRecBound env "define-syntax" if bound@@ -426,7 +440,7 @@ -- Anyway, this may come back. But not using it for now... -- -- defEnv <- liftIO $ copyEnv env- _ <- defineNamespacedVar env macroNamespace keyword $ Syntax (Just env) Nothing False 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@@ -629,6 +643,35 @@ then prepareApply env cont fargs -- if is bound to a variable in this scope; call into it else throwError $ NumArgs (Just 2) args +eval env cont args@(List [Atom "list-set!", Atom var, i, object]) = do+ bound <- liftIO $ isRecBound env "list-set!"+ if bound+ then prepareApply env cont args -- if is bound to a variable in this scope; call into it+ else meval env (makeCPS env cont cpsObj) i+ where+ cpsObj :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal+ cpsObj e c idx _ = meval e (makeCPSWArgs e c cpsList $ [idx]) object++ cpsList :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal+ cpsList e c obj (Just [idx]) = (meval e (makeCPSWArgs e c cpsUpdateList $ [idx, obj]) =<< getVar e var)+ cpsList _ _ _ _ = throwError $ InternalError "Invalid argument to cpsList"++ cpsUpdateList :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal+ cpsUpdateList e c list (Just [idx, obj]) =+ updateList list idx obj >>= updateObject e var >>= continueEval e c+ cpsUpdateList _ _ _ _ = throwError $ InternalError "Invalid argument to cpsUpdateList"++eval env cont args@(List [Atom "list-set!" , nonvar , _ , _]) = do + bound <- liftIO $ isRecBound env "list-set!"+ if bound+ then prepareApply env cont args -- if is bound to a variable in this scope; call into it+ else throwError $ TypeMismatch "variable" nonvar+eval env cont fargs@(List (Atom "list-set!" : args)) = do + bound <- liftIO $ isRecBound env "list-set!"+ if bound+ then prepareApply env cont fargs -- if is bound to a variable in this scope; call into it+ else throwError $ NumArgs (Just 3) args+ eval env cont args@(List [Atom "vector-set!", Atom var, i, object]) = do bound <- liftIO $ isRecBound env "vector-set!" if bound@@ -764,6 +807,19 @@ substr (String _, c, _) = throwError $ TypeMismatch "character" c substr (s, _, _) = throwError $ TypeMismatch "string" s +-- |Replace a list element, by index. Taken from:+-- http://stackoverflow.com/questions/10133361/haskell-replace-element-in-list+replaceAtIndex n item ls = a ++ (item:b) where (a, (_:b)) = splitAt n ls++-- |A helper function for /(list-set!)/+updateList :: LispVal -> LispVal -> LispVal -> IOThrowsError LispVal+updateList (List list) (Number idx) obj = do+ return $ List $ replaceAtIndex (fromInteger idx) obj list+updateList ptr@(Pointer _ _) i obj = do+ list <- derefPtr ptr+ updateList list i obj+updateList l _ _ = throwError $ TypeMismatch "list" l+ -- |A helper function for the special form /(vector-set!)/ updateVector :: LispVal -> LispVal -> LispVal -> IOThrowsError LispVal updateVector (Vector vec) (Number idx) obj = return $ Vector $ vec // [(fromInteger idx, obj)]@@ -934,6 +990,12 @@ where domakeFunc constructor (var, func) = ((varNamespace, var), constructor func) +--baseBindings :: IO Env+--baseBindings = nullEnv >>= +-- (flip extendEnv $ map (domakeFunc EvalFunc) evalFunctions)+-- where domakeFunc constructor (var, func) = +-- ((varNamespace, var), constructor func)+ -- |An empty environment with the %import function. This is presently -- just intended for internal use by the compiler. nullEnvWithImport :: IO Env@@ -982,39 +1044,53 @@ return env +-- |Load the standard r7rs environment, including libraries+r7rsEnv :: IO Env+r7rsEnv = do+ env <- r7rsEnv'+ -- Bit of a hack to load (import)+ _ <- evalLisp' env $ List [Atom "%bootstrap-import"]++ return env -- |Load the standard r7rs environment -- -- TODO: This is just a stub, do not try using it yet! ---r7rsEnv :: IO Env-r7rsEnv = do- -- TODO: should there be a primitive bindings for r7rs??- --env <- primitiveBindings- env <- nullEnv+r7rsEnv' :: IO Env+r7rsEnv' = do+ -- TODO: longer term, will need r7rs bindings instead of these+ -- basically want to limit the base bindings to the absolute minimum, but+ -- need enough to get the meta language working+ env <- primitiveBindings --baseBindings+-- baseEnv <- primitiveBindings --- TODO: these are obsolete with r7rs, should use libraries instead--- stdlib <- PHS.getDataFileName "lib/stdlib.scm"--- srfi55 <- PHS.getDataFileName "lib/srfi/srfi-55.scm" -- (require-extension)--- --- -- Load standard library--- _ <- evalString env $ "(load \"" ++ (escapeBackslashes stdlib) ++ "\")" ------ -- Load (require-extension), which can be used to load other SRFI's--- _ <- evalString env $ "(load \"" ++ (escapeBackslashes srfi55) ++ "\")"--- registerExtensions env PHS.getDataFileName+ -- Load necessary libraries+ -- Unfortunately this adds them in the top-level environment (!!)+ cxr <- PHS.getDataFileName "lib/cxr.scm"+ _ <- evalString env {-baseEnv-} $ "(load \"" ++ (escapeBackslashes cxr) ++ "\")" + core <- PHS.getDataFileName "lib/core.scm"+ _ <- evalString env {-baseEnv-} $ "(load \"" ++ (escapeBackslashes core) ++ "\")" +-- TODO: probably will have to load some scheme libraries for modules.scm to work+-- maybe the 'base' libraries from (scheme base) would be good enough?++#ifdef UseLibraries -- Load module meta-language - -- Note: there is no ifdef here because modules are a core part of r7rs metalib <- PHS.getDataFileName "lib/modules.scm" metaEnv <- nullEnvWithParent env -- Load env as parent of metaenv _ <- evalString metaEnv $ "(load \"" ++ (escapeBackslashes metalib) ++ "\")" -- Load meta-env so we can find it later _ <- evalLisp' env $ List [Atom "define", Atom "*meta-env*", LispEnv metaEnv]- -- Bit of a hack to load (import)- _ <- evalLisp' env $ List [Atom "%bootstrap-import"]- -- Load (r5rs base)- _ <- evalString metaEnv- "(add-module! '(scheme r5rs) (make-module #f (interaction-environment) '()))"+ -- Load base primitives+ _ <- evalLisp' metaEnv $ List [Atom "add-module!", List [Atom "quote", List [Atom "scheme"]], List [Atom "make-module", Bool False, LispEnv env {-baseEnv-}, List [Atom "quote", List []]]]++ timeEnv <- liftIO $ r7rsTimeEnv+ _ <- evalLisp' metaEnv $ List [Atom "add-module!", List [Atom "quote", List [Atom "scheme", Atom "time", Atom "posix"]], List [Atom "make-module", Bool False, LispEnv timeEnv, List [Atom "quote", List []]]]++ processContextEnv <- liftIO $ r7rsProcessContextEnv+ _ <- evalLisp' metaEnv $ List [Atom "add-module!", List [Atom "quote", List [Atom "scheme", Atom "process-context"]], List [Atom "make-module", Bool False, LispEnv processContextEnv, List [Atom "quote", List []]]]+#endif+ return env -- | Load haskell bindings used for the r7rs time library@@ -1024,6 +1100,14 @@ (flip extendEnv [ ((varNamespace, "current-second"), IOFunc currentTimestamp)]) +r7rsProcessContextEnv :: IO Env+r7rsProcessContextEnv = do+ nullEnv >>= + (flip extendEnv + [ + -- TODO: need a lot more here, this is just a stub+ ((varNamespace, "exit"), IOFunc evalfuncExitFail)])+ -- Functions that extend the core evaluator, but that can be defined separately. -- {- These functions have access to the current environment via the@@ -1243,235 +1327,3 @@ , ("exit-fail", evalfuncExitFail) , ("exit-success", evalfuncExitSuccess) ]--{- I/O primitives-Primitive functions that execute within the IO monad -}-ioPrimitives :: [(String, [LispVal] -> IOThrowsError LispVal)]-ioPrimitives = [("open-input-file", makePort ReadMode),- ("open-output-file", makePort WriteMode),- ("close-input-port", closePort),- ("close-output-port", closePort),- ("input-port?", isInputPort),- ("output-port?", isOutputPort),- ("char-ready?", isCharReady),-- -- The following optional procedures are NOT implemented:- --- {- with-input-from-file- with-output-from-file- transcript-on- transcript-off -}- --- {- Consideration may be given in a future release, but keep in mind- the impact to the other I/O functions. -}-- ("current-input-port", currentInputPort),- ("current-output-port", currentOutputPort),- ("read", readProc),- ("read-char", readCharProc hGetChar),- ("peek-char", readCharProc hLookAhead),- ("write", writeProc (\ port obj -> hPrint port obj)),- ("write-char", writeCharProc),- ("display", writeProc (\ port obj -> do- case obj of- String str -> hPutStr port str- _ -> hPutStr port $ show obj)),-- ("string=?", strBoolBinop (==)),- ("string<?", strBoolBinop (<)),- ("string>?", strBoolBinop (>)),- ("string<=?", strBoolBinop (<=)),- ("string>=?", strBoolBinop (>=)),- ("string-ci=?", stringCIEquals),- ("string-ci<?", stringCIBoolBinop (<)),- ("string-ci>?", stringCIBoolBinop (>)),- ("string-ci<=?", stringCIBoolBinop (<=)),- ("string-ci>=?", stringCIBoolBinop (>=)),- ("string->symbol", string2Symbol),-- ("car", car),- ("cdr", cdr),- ("cons", cons),-- -- TODO: these need to be rewritten to actually be in - -- the IO monad, tmpWrap is just temporary- ("eq?", tmpWrap eqv),- ("eqv?", tmpWrap eqv),- ("equal?", tmpWrap equal),-- ("pair?", isDottedList),- ("list?", unaryOp' isList),- ("vector?", unaryOp' isVector),- ("null?", isNull),- ("string?", isString),-- ("string-length", stringLength),- ("string-ref", stringRef),- ("substring", substring),- ("string-append", stringAppend),- ("string->number", stringToNumber),- ("string->list", stringToList),- ("list->string", listToString),- ("string-copy", stringCopy),- ("string->utf8", byteVectorStr2Utf),-- ("bytevector?", unaryOp' isByteVector),- ("bytevector-length", byteVectorLength),- ("bytevector-u8-ref", byteVectorRef),- ("bytevector-append", byteVectorAppend),- ("bytevector-copy", byteVectorCopy),- ("utf8->string", byteVectorUtf2Str),-- ("vector-length",wrapLeadObj vectorLength),- ("vector-ref", wrapLeadObj vectorRef),- ("vector->list", wrapLeadObj vectorToList),- ("list->vector", wrapLeadObj listToVector),-- ("hash-table?", wrapHashTbl isHashTbl),- ("hash-table-exists?",wrapHashTbl hashTblExists),- ("hash-table-ref", wrapHashTbl hashTblRef),- ("hash-table-size", wrapHashTbl hashTblSize),- ("hash-table->alist", wrapHashTbl hashTbl2List),- ("hash-table-keys", wrapHashTbl hashTblKeys),- ("hash-table-values", wrapHashTbl hashTblValues),- ("hash-table-copy", wrapHashTbl hashTblCopy),-- -- From SRFI 96- ("file-exists?", fileExists),- ("delete-file", deleteFile),-- -- husk internal functions- --("husk-path", getDataFileFullPath'),-- -- Other I/O functions- ("print-env", printEnv'),- ("env-exports", exportsFromEnv'),- ("read-contents", readContents),- ("read-all", readAll),- ("find-module-file", findModuleFile),- ("system", system),- ("gensym", gensym)]---- TODO:--- This function is a temporary stopgap that will go--- away before this branch is merged-tmpWrap :: ([LispVal] -> ThrowsError LispVal) -> [LispVal] -> IOThrowsError LispVal-tmpWrap fnc lvs = do- List result <- recDerefPtrs $ List lvs - liftThrows $ fnc result--printEnv' :: [LispVal] -> IOThrowsError LispVal-printEnv' [LispEnv env] = do- result <- liftIO $ printEnv env- return $ String result-printEnv' [] = throwError $ NumArgs (Just 1) []-printEnv' args = throwError $ TypeMismatch "env" $ List args--exportsFromEnv' :: [LispVal] -> IOThrowsError LispVal-exportsFromEnv' [LispEnv env] = do- result <- liftIO $ exportsFromEnv env- return $ List result-exportsFromEnv' err = return $ List []--{- "Pure" primitive functions -}-primitives :: [(String, [LispVal] -> ThrowsError LispVal)]-primitives = [("+", numAdd),- ("-", numSub),- ("*", numMul),- ("/", numDiv),- ("modulo", numMod),- ("quotient", numericBinop quot),- ("remainder", numericBinop rem),- ("rationalize", numRationalize),-- ("round", numRound),- ("floor", numFloor),- ("ceiling", numCeiling),- ("truncate", numTruncate),-- ("numerator", numNumerator),- ("denominator", numDenominator),-- ("exp", numExp),- ("log", numLog),- ("sin", numSin),- ("cos", numCos),- ("tan", numTan),- ("asin", numAsin),- ("acos", numAcos),- ("atan", numAtan),-- ("sqrt", numSqrt),- ("expt", numExpt),-- ("make-rectangular", numMakeRectangular),- ("make-polar", numMakePolar),- ("real-part", numRealPart ),- ("imag-part", numImagPart),- ("magnitude", numMagnitude),- ("angle", numAngle ),-- ("exact->inexact", numExact2Inexact),- ("inexact->exact", numInexact2Exact),-- ("number->string", num2String),-- ("=", numBoolBinopEq),- (">", numBoolBinopGt),- (">=", numBoolBinopGte),- ("<", numBoolBinopLt),- ("<=", numBoolBinopLte),-- ("&&", boolBoolBinop (&&)),- ("||", boolBoolBinop (||)),-- ("char=?", charBoolBinop (==)),- ("char<?", charBoolBinop (<)),- ("char>?", charBoolBinop (>)),- ("char<=?", charBoolBinop (<=)),- ("char>=?", charBoolBinop (>=)),- ("char-ci=?", charCIBoolBinop (==)),- ("char-ci<?", charCIBoolBinop (<)),- ("char-ci>?", charCIBoolBinop (>)),- ("char-ci<=?", charCIBoolBinop (<=)),- ("char-ci>=?", charCIBoolBinop (>=)),- ("char-alphabetic?", charPredicate Data.Char.isAlpha),- ("char-numeric?", charPredicate Data.Char.isNumber),- ("char-whitespace?", charPredicate Data.Char.isSpace),- ("char-upper-case?", charPredicate Data.Char.isUpper),- ("char-lower-case?", charPredicate Data.Char.isLower),- ("char->integer", char2Int),- ("integer->char", int2Char),- ("char-upper", charUpper),- ("char-lower", charLower),-- ("procedure?", isProcedure),- ("number?", isNumber),- ("complex?", isComplex),- ("real?", isReal),- ("rational?", isRational),- ("integer?", isInteger),- ("eof-object?", isEOFObject),- ("symbol?", isSymbol),- ("symbol->string", symbol2String),- ("char?", isChar),-- ("make-vector", makeVector),- ("vector", buildVector),-- ("make-bytevector", makeByteVector),- ("bytevector", byteVector),-- ("make-hash-table", hashTblMake),- ("string", buildString),- ("make-string", makeString),-- ("boolean?", isBoolean),-- ("husk-interpreter?", isInterpreter)]---- |Custom function used internally in the test suite-isInterpreter :: [LispVal] -> ThrowsError LispVal-isInterpreter [] = return $ Bool True-isInterpreter _ = return $ Bool False-
+ hs-src/Language/Scheme/Environments.hs view
@@ -0,0 +1,255 @@++{- |+Module : Language.Scheme.Environments+Copyright : Justin Ethier+Licence : MIT (see LICENSE in the distribution)++Maintainer : github.com/justinethier+Stability : experimental+Portability : portable++-}++module Language.Scheme.Environments+ (+ primitives+ , ioPrimitives+ ) where+import Language.Scheme.Libraries+import Language.Scheme.Numerical+import Language.Scheme.Primitives+import Language.Scheme.Types+import Language.Scheme.Util+import Language.Scheme.Variables+import Control.Monad.Error+import qualified Data.Char+import System.IO++{- I/O primitives+Primitive functions that execute within the IO monad -}+ioPrimitives :: [(String, [LispVal] -> IOThrowsError LispVal)]+ioPrimitives = [("open-input-file", makePort ReadMode),+ ("open-output-file", makePort WriteMode),+ ("close-input-port", closePort),+ ("close-output-port", closePort),+ ("input-port?", isInputPort),+ ("output-port?", isOutputPort),+ ("char-ready?", isCharReady),++ -- The following optional procedures are NOT implemented:+ --+ {- with-input-from-file+ with-output-from-file+ transcript-on+ transcript-off -}+ --+ {- Consideration may be given in a future release, but keep in mind+ the impact to the other I/O functions. -}++ ("current-input-port", currentInputPort),+ ("current-output-port", currentOutputPort),+ ("read", readProc),+ ("read-char", readCharProc hGetChar),+ ("peek-char", readCharProc hLookAhead),+ ("write", writeProc (\ port obj -> hPrint port obj)),+ ("write-char", writeCharProc),+ ("display", writeProc (\ port obj -> do+ case obj of+ String str -> hPutStr port str+ _ -> hPutStr port $ show obj)),++ ("string=?", strBoolBinop (==)),+ ("string<?", strBoolBinop (<)),+ ("string>?", strBoolBinop (>)),+ ("string<=?", strBoolBinop (<=)),+ ("string>=?", strBoolBinop (>=)),+ ("string-ci=?", stringCIEquals),+ ("string-ci<?", stringCIBoolBinop (<)),+ ("string-ci>?", stringCIBoolBinop (>)),+ ("string-ci<=?", stringCIBoolBinop (<=)),+ ("string-ci>=?", stringCIBoolBinop (>=)),+ ("string->symbol", string2Symbol),++ ("car", car),+ ("cdr", cdr),+ ("cons", cons),++ ("eq?", eq),+ ("eqv?", eq), -- TODO: not quite right, but maybe good enough for now+ ("equal?", recDerefToFnc equal),++ ("pair?", isDottedList),+ ("list?", unaryOp' isList),+ ("vector?", unaryOp' isVector),+ ("null?", isNull),+ ("string?", isString),++ ("list-copy", listCopy),++ ("string-length", stringLength),+ ("string-ref", stringRef),+ ("substring", substring),+ ("string-append", stringAppend),+ ("string->number", stringToNumber),+ ("string->list", stringToList),+ ("list->string", listToString),+ ("string->vector", stringToVector),+ ("vector->string", vectorToString),+ ("string-copy", stringCopy),+ ("string->utf8", byteVectorStr2Utf),++ ("bytevector?", unaryOp' isByteVector),+ ("bytevector-length", byteVectorLength),+ ("bytevector-u8-ref", byteVectorRef),+ ("bytevector-append", byteVectorAppend),+ ("bytevector-copy", byteVectorCopy),+ ("utf8->string", byteVectorUtf2Str),++ ("vector-length",wrapLeadObj vectorLength),+ ("vector-ref", wrapLeadObj vectorRef),+ ("vector-copy", vectorCopy),+ ("vector->list", wrapLeadObj vectorToList),+ ("list->vector", wrapLeadObj listToVector),++ ("hash-table?", wrapHashTbl isHashTbl),+ ("hash-table-exists?",wrapHashTbl hashTblExists),+ ("hash-table-ref", wrapHashTbl hashTblRef),+ ("hash-table-size", wrapHashTbl hashTblSize),+ ("hash-table->alist", wrapHashTbl hashTbl2List),+ ("hash-table-keys", wrapHashTbl hashTblKeys),+ ("hash-table-values", wrapHashTbl hashTblValues),+ ("hash-table-copy", wrapHashTbl hashTblCopy),++ -- From SRFI 96+ ("file-exists?", fileExists),+ ("delete-file", deleteFile),++ -- husk internal functions+ --("husk-path", getDataFileFullPath'),++ -- Other I/O functions+ ("print-env", printEnv'),+ ("env-exports", exportsFromEnv'),+ ("read-contents", readContents),+ ("read-all", readAll),+ ("find-module-file", findModuleFile),+ ("system", system),+ ("gensym", gensym)]+++printEnv' :: [LispVal] -> IOThrowsError LispVal+printEnv' [LispEnv env] = do+ result <- liftIO $ printEnv env+ return $ String result+printEnv' [] = throwError $ NumArgs (Just 1) []+printEnv' args = throwError $ TypeMismatch "env" $ List args++exportsFromEnv' :: [LispVal] -> IOThrowsError LispVal+exportsFromEnv' [LispEnv env] = do+ result <- liftIO $ exportsFromEnv env+ return $ List result+exportsFromEnv' err = return $ List []++{- "Pure" primitive functions -}+primitives :: [(String, [LispVal] -> ThrowsError LispVal)]+primitives = [("+", numAdd),+ ("-", numSub),+ ("*", numMul),+ ("/", numDiv),+ ("modulo", numMod),+ ("quotient", numericBinop quot),+ ("remainder", numericBinop rem),+ ("rationalize", numRationalize),++ ("round", numRound),+ ("floor", numFloor),+ ("ceiling", numCeiling),+ ("truncate", numTruncate),++ ("numerator", numNumerator),+ ("denominator", numDenominator),++ ("exp", numExp),+ ("log", numLog),+ ("sin", numSin),+ ("cos", numCos),+ ("tan", numTan),+ ("asin", numAsin),+ ("acos", numAcos),+ ("atan", numAtan),++ ("sqrt", numSqrt),+ ("expt", numExpt),++ ("make-rectangular", numMakeRectangular),+ ("make-polar", numMakePolar),+ ("real-part", numRealPart ),+ ("imag-part", numImagPart),+ ("magnitude", numMagnitude),+ ("angle", numAngle ),++ ("exact->inexact", numExact2Inexact),+ ("inexact->exact", numInexact2Exact),++ ("number->string", num2String),++ ("=", numBoolBinopEq),+ (">", numBoolBinopGt),+ (">=", numBoolBinopGte),+ ("<", numBoolBinopLt),+ ("<=", numBoolBinopLte),++ ("&&", boolBoolBinop (&&)),+ ("||", boolBoolBinop (||)),++ ("char=?", charBoolBinop (==)),+ ("char<?", charBoolBinop (<)),+ ("char>?", charBoolBinop (>)),+ ("char<=?", charBoolBinop (<=)),+ ("char>=?", charBoolBinop (>=)),+ ("char-ci=?", charCIBoolBinop (==)),+ ("char-ci<?", charCIBoolBinop (<)),+ ("char-ci>?", charCIBoolBinop (>)),+ ("char-ci<=?", charCIBoolBinop (<=)),+ ("char-ci>=?", charCIBoolBinop (>=)),+ ("char-alphabetic?", charPredicate Data.Char.isAlpha),+ ("char-numeric?", charPredicate Data.Char.isNumber),+ ("char-whitespace?", charPredicate Data.Char.isSpace),+ ("char-upper-case?", charPredicate Data.Char.isUpper),+ ("char-lower-case?", charPredicate Data.Char.isLower),+ ("char->integer", char2Int),+ ("integer->char", int2Char),+ ("char-upper", charUpper),+ ("char-lower", charLower),++ ("procedure?", isProcedure),+ ("number?", isNumber),+ ("complex?", isComplex),+ ("real?", isReal),+ ("rational?", isRational),+ ("integer?", isInteger),+ ("eof-object?", isEOFObject),+ ("symbol?", isSymbol),+ ("symbol->string", symbol2String),+ ("char?", isChar),++ ("make-list", makeList),+ ("make-vector", makeVector),+ ("vector", buildVector),++ ("make-bytevector", makeByteVector),+ ("bytevector", byteVector),++ ("make-hash-table", hashTblMake),+ ("string", buildString),+ ("make-string", makeString),++ ("boolean?", isBoolean),++ ("husk-interpreter?", isInterpreter)]++-- |Custom function used internally in the test suite+isInterpreter :: [LispVal] -> ThrowsError LispVal+isInterpreter [] = return $ Bool True+isInterpreter _ = return $ Bool False+
hs-src/Language/Scheme/Libraries.hs view
@@ -29,27 +29,29 @@ -> IOThrowsError LispVal findModuleFile [p@(Pointer _ _)] = recDerefPtrs p >>= box >>= findModuleFile findModuleFile [String file] - -- Built-in modules- | file == "scheme/r5rs/base.sld" ||- file == "scheme/r5rs/char.sld" ||- file == "scheme/r5rs/complex.sld" ||- file == "scheme/r5rs/cxr.sld" ||- file == "scheme/r5rs/eval.sld" ||- file == "scheme/r5rs/file.sld" ||- file == "scheme/r5rs/inexact.sld" ||- file == "scheme/r5rs/lazy.sld" ||- file == "scheme/r5rs/load.sld" ||- file == "scheme/r5rs/read.sld" ||- file == "scheme/r5rs/write.sld" ||- file == "scheme/base.sld" ||- file == "husk/pretty-print.sld" ||--- TODO: scheme case-lambda (r7rs)--- TODO: scheme process-context (r7rs)--- TODO: scheme repl (r7rs)- file == "scheme/time.sld" ||- file == "scheme/write.sld" = do- path <- liftIO $ PHS.getDataFileName $ "lib/" ++ file- return $ String path+-- This is no longer required since load has been enhanced to+-- attempt to load a file from 'lib' if it does not exist+-- -- Built-in modules+-- | --file == "scheme/r5rs/base.sld" ||+-- --file == "scheme/r5rs/char.sld" ||+-- --file == "scheme/r5rs/complex.sld" ||+-- --file == "scheme/r5rs/cxr.sld" ||+-- --file == "scheme/r5rs/eval.sld" ||+-- --file == "scheme/r5rs/file.sld" ||+-- --file == "scheme/r5rs/inexact.sld" ||+-- --file == "scheme/r5rs/lazy.sld" ||+-- --file == "scheme/r5rs/load.sld" ||+-- --file == "scheme/r5rs/read.sld" ||+-- --file == "scheme/r5rs/write.sld" ||+-- --file == "scheme/base.sld" ||+-- file == "husk/pretty-print.sld" ||+---- TODO: scheme case-lambda (r7rs)+---- TODO: scheme process-context (r7rs)+---- TODO: scheme repl (r7rs)+-- file == "scheme/time.sld" ||+-- file == "scheme/write.sld" = do+-- path <- liftIO $ PHS.getDataFileName $ "lib/" ++ file+-- return $ String path | otherwise = return $ String file findModuleFile _ = return $ Bool False
hs-src/Language/Scheme/Macro.hs view
@@ -91,17 +91,11 @@ -- This should work because any env changes would only affect the new environment and not -- the parent one. The disadvantage is that macroEval is called in several places in Core. -- It's calls will need to be modified to use a new function that will pass along the--- extended env if necessary. I am a bit concerned about suble errors occuring if any+-- extended env if necessary. I am a bit concerned about subtle errors occurring if any -- continuations in the chain are not updated and still have the old environment in them. -- It may be tricky to get this right. But otherwise the change *should* be straightforward. --- Currently unused, and likely to go away:--- A support function for Core that will be used as part of the above...---needToExtendEnv :: LispVal -> Bool --IOThrowsError LispVal---needToExtendEnv (List [Atom "define-syntax", Atom _, (List (Atom "syntax-rules" : (List _ : _)))]) = True---needToExtendEnv _ = False - -- |Get a list of variables that the macro hygiene -- subsystem diverted back into the calling environment. --@@ -144,7 +138,7 @@ _macroEval env lisp@(List (Atom x : _)) apply = do -- Note: If there is a procedure of the same name it will be shadowed by the macro. var <- getNamespacedVar' env macroNamespace x- -- DEBUG: var <- (trace ("expand: " ++ x) getNamespacedVar) env macroNamespace x+ -- DEBUG: var <- (trace ("expand: " ++ x) getNamespacedVar') env macroNamespace x case var of -- Explicit Renaming Just (SyntaxExplicitRenaming transformer@(Func _ _ _ _)) -> do@@ -154,7 +148,7 @@ _macroEval env expanded apply -- Syntax Rules- Just (Syntax (Just defEnv) _ definedInMacro identifiers rules) -> do+ Just (Syntax (Just defEnv) _ definedInMacro ellipsis identifiers rules) -> do renameEnv <- liftIO $ nullEnv -- Local environment used just for this -- invocation to hold renamed variables cleanupEnv <- liftIO $ nullEnv -- Local environment used just for @@ -168,6 +162,7 @@ expanded <- macroTransform defEnv env env renameEnv cleanupEnv definedInMacro (List identifiers) rules lisp apply+ ellipsis _macroEval env expanded apply -- Useful debug to see all exp's: -- macroEval env (trace ("exp = " ++ show expanded) expanded)@@ -199,35 +194,34 @@ -> [LispVal] -> LispVal -> (LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal) -- ^Apply func+ -> String -- ^ Ellipsis symbol -> IOThrowsError LispVal-macroTransform defEnv env divertEnv renameEnv cleanupEnv dim identifiers (rule@(List _) : rs) input apply = do+macroTransform defEnv env divertEnv renameEnv cleanupEnv dim identifiers (rule@(List _) : rs) input apply esym = do localEnv <- liftIO $ nullEnv -- Local environment used just for this invocation -- to hold pattern variables- result <- matchRule defEnv env divertEnv dim identifiers localEnv renameEnv cleanupEnv rule input+ result <- matchRule defEnv env divertEnv dim identifiers localEnv renameEnv cleanupEnv rule input esym case (result) of -- No match, check the next rule- Nil _ -> macroTransform defEnv env divertEnv renameEnv cleanupEnv dim identifiers rs input apply+ Nil _ -> macroTransform defEnv env divertEnv renameEnv cleanupEnv dim identifiers rs input apply esym _ -> do -- Walk the resulting code, performing the Clinger algorithm's 4 components walkExpanded defEnv env divertEnv renameEnv cleanupEnv dim True False (List []) (result) apply -- 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-macroElementMatchesMany (List (_ : ps)) = do+macroElementMatchesMany :: LispVal -> String -> Bool+macroElementMatchesMany args@(List (_ : ps)) ellipsisSym = do if not (null ps)- then case (head ps) of- Atom "..." -> True- _ -> False+ then (head ps) == (Atom ellipsisSym) else False-macroElementMatchesMany _ = False+macroElementMatchesMany _ _ = False {- Given input, determine if that input matches any rules @return Transformed code, or Nil if no rules match -}-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+matchRule :: Env -> Env -> Env -> Bool -> LispVal -> Env -> Env -> Env -> LispVal -> LispVal -> String -> IOThrowsError LispVal+matchRule defEnv outerEnv divertEnv dim identifiers localEnv renameEnv cleanupEnv (List [pattern, template]) (List inputVar) esym = do let is = tail inputVar let p = case pattern of DottedList ds d -> case ds of@@ -242,7 +236,7 @@ case match of Bool False -> return $ Nil "" _ -> do- transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers 0 [] (List []) template+ transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers esym 0 [] (List []) template _ -> throwError $ BadSpecialForm "Malformed rule in syntax-rules" $ String $ show p where@@ -252,28 +246,30 @@ case is of (DottedList _ _ : _) -> do loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers - (List $ ds ++ [d, Atom "..."])+ (List $ ds ++ [d, Atom esym]) (List is) 0 [] (flagDottedLists [] (False, False) 0)+ esym (List _ : _) -> do loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers - (List $ ds ++ [d, Atom "..."])+ (List $ ds ++ [d, Atom esym]) (List is) 0 [] (flagDottedLists [] (True, False) 0)- _ -> loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers (List ps) (List is) 0 [] []+ esym+ _ -> loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers (List ps) (List is) 0 [] [] esym -- No pair, immediately begin matching- checkPattern ps is _ = loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers (List ps) (List is) 0 [] [] + checkPattern ps is _ = loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers (List ps) (List is) 0 [] [] esym -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 -> Env -> LispVal -> LispVal -> LispVal -> Int -> [Int] -> [(Bool, Bool)] -> IOThrowsError LispVal-loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers pattern input ellipsisLevel ellipsisIndex listFlags = do+loadLocal :: Env -> Env -> Env -> Env -> Env -> LispVal -> LispVal -> LispVal -> Int -> [Int] -> [(Bool, Bool)] -> String -> IOThrowsError LispVal+loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers pattern input ellipsisLevel ellipsisIndex listFlags esym = do case (pattern, input) of ((DottedList ps p), (DottedList isRaw iRaw)) -> do@@ -285,21 +281,22 @@ let is = fst isSplit let i = (snd isSplit) ++ [iRaw] - result <- loadLocal defEnv outerEnv divertEnv 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 esym case result of Bool True -> -- By matching on an elipsis we force the code -- to match pagainst all elements in i. loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers - (List $ [p, Atom "..."]) + (List $ [p, Atom esym]) (List i) ellipsisLevel -- Incremented in the list/list match below ellipsisIndex (flagDottedLists listFlags (True, True) $ length ellipsisIndex)+ esym _ -> return $ Bool False (List (p : ps), List (i : is)) -> do -- check first input against first pattern, recurse... - let nextHasEllipsis = macroElementMatchesMany pattern+ let nextHasEllipsis = macroElementMatchesMany pattern esym let level = if nextHasEllipsis then ellipsisLevel + 1 else ellipsisLevel let idx = if nextHasEllipsis @@ -313,7 +310,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 divertEnv (localEnv) renameEnv identifiers level idx p i listFlags+ status <- checkLocal defEnv outerEnv divertEnv (localEnv) renameEnv identifiers level idx p i listFlags esym case (status) of -- No match Bool False -> if nextHasEllipsis@@ -321,8 +318,8 @@ Move past it, but keep the same input. -} 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 divertEnv localEnv renameEnv identifiers (List $ tail ps) (List (i : is)) ellipsisLevel ellipsisIndex listFlags+ [Atom esym] -> return $ Bool True -- An otherwise empty list, so just let the caller know match is done+ _ -> loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers (List $ tail ps) (List (i : is)) ellipsisLevel ellipsisIndex listFlags esym else return $ Bool False -- There was a match _ -> if nextHasEllipsis@@ -331,28 +328,29 @@ 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 divertEnv localEnv renameEnv identifiers (List ps) (List is) ellipsisLevel ellipsisIndex listFlags+ esym+ else loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers (List ps) (List is) ellipsisLevel ellipsisIndex listFlags esym -- Base case - All data processed (List [], List []) -> return $ Bool True -- Ran out of input to process (List (_ : _), List []) -> do- if (macroElementMatchesMany pattern)+ if (macroElementMatchesMany pattern esym) 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 defEnv outerEnv localEnv identifiers pattern $ fst flags+ flagUnmatchedVars defEnv outerEnv localEnv identifiers pattern (fst flags) esym 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 defEnv outerEnv divertEnv localEnv renameEnv identifiers ellipsisLevel ellipsisIndex pattern input listFlags+ (_, _) -> checkLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers ellipsisLevel ellipsisIndex pattern input listFlags esym -- -- |Utility function to flag pattern variables as 'no match' that exist in the @@ -364,26 +362,26 @@ -- This information is necessary for use during transformation, where the output may -- change depending upon the form of the input. ---flagUnmatchedVars :: Env -> Env -> Env -> LispVal -> LispVal -> Bool -> IOThrowsError LispVal --flagUnmatchedVars defEnv outerEnv localEnv identifiers (DottedList ps p) partOfImproperPattern = do- flagUnmatchedVars defEnv outerEnv localEnv identifiers (List $ ps ++ [p]) partOfImproperPattern+flagUnmatchedVars :: Env -> Env -> Env -> LispVal -> LispVal -> Bool -> String -> IOThrowsError LispVal -flagUnmatchedVars defEnv outerEnv localEnv identifiers (Vector p) partOfImproperPattern = do- flagUnmatchedVars defEnv outerEnv localEnv identifiers (List $ elems p) partOfImproperPattern+flagUnmatchedVars defEnv outerEnv localEnv identifiers (DottedList ps p) partOfImproperPattern esym = do+ flagUnmatchedVars defEnv outerEnv localEnv identifiers (List $ ps ++ [p]) partOfImproperPattern esym -flagUnmatchedVars _ _ _ _ (List []) _ = return $ Bool True +flagUnmatchedVars defEnv outerEnv localEnv identifiers (Vector p) partOfImproperPattern esym = do+ flagUnmatchedVars defEnv outerEnv localEnv identifiers (List $ elems p) partOfImproperPattern esym -flagUnmatchedVars defEnv outerEnv localEnv identifiers (List (p : ps)) partOfImproperPattern = do- _ <- flagUnmatchedVars defEnv outerEnv localEnv identifiers p partOfImproperPattern- flagUnmatchedVars defEnv outerEnv localEnv identifiers (List ps) partOfImproperPattern+flagUnmatchedVars _ _ _ _ (List []) _ _ = return $ Bool True -flagUnmatchedVars _ _ _ _ (Atom "...") _ = return $ Bool True +flagUnmatchedVars defEnv outerEnv localEnv identifiers (List (p : ps)) partOfImproperPattern esym = do+ _ <- flagUnmatchedVars defEnv outerEnv localEnv identifiers p partOfImproperPattern esym+ flagUnmatchedVars defEnv outerEnv localEnv identifiers (List ps) partOfImproperPattern esym -flagUnmatchedVars defEnv outerEnv localEnv identifiers (Atom p) partOfImproperPattern =- flagUnmatchedAtom defEnv outerEnv localEnv identifiers p partOfImproperPattern+flagUnmatchedVars defEnv outerEnv localEnv identifiers (Atom p) partOfImproperPattern esym =+ if p == esym+ then return $ Bool True+ else flagUnmatchedAtom defEnv outerEnv localEnv identifiers p partOfImproperPattern -flagUnmatchedVars _ _ _ _ _ _ = return $ Bool True +flagUnmatchedVars _ _ _ _ _ _ _ = return $ Bool True -- |Flag an atom that did not have any matching input --@@ -432,25 +430,26 @@ | 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 -- 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- -> 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+-- ^ 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+ -> 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+ -> String -- ^ Symbol used to specify ellipsis (IE, 0 or many match) -> 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 _ localEnv renameEnv identifiers ellipsisLevel ellipsisIndex (Atom pattern) input listFlags esym = do -- TODO: --@@ -556,26 +555,27 @@ _ <- defineNamespacedVar localEnv 'p' {-"improper pattern"-} pat $ Bool $ fst flags defineNamespacedVar localEnv 'i' {-"improper input"-} pat $ Bool $ snd flags -checkLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers ellipsisLevel ellipsisIndex (Vector p) (Vector i) flags =+checkLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers ellipsisLevel ellipsisIndex (Vector p) (Vector i) flags esym = -- 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 divertEnv 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 esym -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 divertEnv localEnv renameEnv identifiers ellipsisLevel ellipsisIndex pattern@(DottedList _ _) input@(DottedList _ _) flags esym =+ loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers pattern input ellipsisLevel ellipsisIndex flags esym -checkLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers ellipsisLevel ellipsisIndex (DottedList ps p) input@(List (_ : _)) flags = do+checkLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers ellipsisLevel ellipsisIndex (DottedList ps p) input@(List (_ : _)) flags esym = do loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers - (List $ ps ++ [p, Atom "..."])+ (List $ ps ++ [p, Atom esym]) input ellipsisLevel -- Incremented in the list/list match below ellipsisIndex- (flagDottedLists flags (True, False) $ length ellipsisIndex)-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+ (flagDottedLists flags (True, False) $ length ellipsisIndex) + esym+checkLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers ellipsisLevel ellipsisIndex pattern@(List _) input@(List _) flags esym =+ loadLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers pattern input ellipsisLevel ellipsisIndex flags esym -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.@@ -778,11 +778,19 @@ walkExpandedAtom _ useEnv _ renameEnv _ _ True _ (List _) "define-syntax" + ([Atom keyword, (List (Atom "syntax-rules" : Atom ellipsis : (List identifiers : rules)))])+ False _ _ = do+ -- Do we need to rename the keyword, or at least take that into account?+ renameEnvClosure <- liftIO $ copyEnv renameEnv+ _ <- defineNamespacedVar useEnv macroNamespace keyword $ Syntax (Just useEnv) (Just renameEnvClosure) True ellipsis identifiers rules+ return $ Nil "" -- Sentinal value+walkExpandedAtom _ useEnv _ renameEnv _ _ True _ (List _)+ "define-syntax" ([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? renameEnvClosure <- liftIO $ copyEnv renameEnv- _ <- defineNamespacedVar useEnv macroNamespace keyword $ Syntax (Just useEnv) (Just renameEnvClosure) True identifiers rules+ _ <- defineNamespacedVar useEnv macroNamespace keyword $ Syntax (Just useEnv) (Just renameEnvClosure) True "..." identifiers rules return $ Nil "" -- Sentinal value walkExpandedAtom _ useEnv _ renameEnv _ _ True _ (List _) "define-syntax" @@ -877,7 +885,7 @@ -- within another macro. So defEnv is not modified by this macro definition, and -- there is no need to insert it. --- Syntax _ (Just renameClosure) definedInMacro identifiers rules -> do + Syntax _ (Just renameClosure) definedInMacro ellipsis identifiers rules -> do -- Before expanding the macro, make a pass across the macro body to mark -- any instances of renamed variables. -- @@ -889,17 +897,17 @@ -- implementation, and that this solution may not be complete. -- List lexpanded <- cleanExpanded defEnv useEnv divertEnv renameEnv renameEnv True False (List []) (List ts) apply- macroTransform defEnv useEnv divertEnv renameClosure cleanupEnv definedInMacro (List identifiers) rules (List (Atom a : lexpanded)) apply- Syntax (Just _defEnv) _ definedInMacro identifiers rules -> do - macroTransform _defEnv useEnv divertEnv renameEnv cleanupEnv definedInMacro (List identifiers) rules (List (Atom a : ts)) apply- Syntax Nothing _ definedInMacro identifiers rules -> do + macroTransform defEnv useEnv divertEnv renameClosure cleanupEnv definedInMacro (List identifiers) rules (List (Atom a : lexpanded)) apply ellipsis+ Syntax (Just _defEnv) _ definedInMacro ellipsis identifiers rules -> do + macroTransform _defEnv useEnv divertEnv renameEnv cleanupEnv definedInMacro (List identifiers) rules (List (Atom a : ts)) apply ellipsis+ Syntax Nothing _ definedInMacro ellipsis 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)) apply+ macroTransform defEnv useEnv divertEnv renameEnv cleanupEnv definedInMacro (List identifiers) rules (List (Atom a : ts)) apply ellipsis SyntaxExplicitRenaming transformer -> do erRenameEnv <- liftIO $ nullEnv -- Local environment used just for this -- Different than the syntax-rules rename env (??)@@ -1034,6 +1042,7 @@ -> Env -- ^ Environment local to the macro used to cleanup any left-over renamed vars -> Bool -> LispVal -- ^ Literal identifiers+ -> String -- ^ ellipsisSymbol - Symbol used to identify an ellipsis -> 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.@@ -1043,77 +1052,81 @@ -> IOThrowsError LispVal -- Recursively transform a list-transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List result) transform@(List (List l : ts)) = do- let nextHasEllipsis = macroElementMatchesMany transform+transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers esym ellipsisLevel ellipsisIndex (List result) transform@(List (List l : ts)) = do+ let nextHasEllipsis = macroElementMatchesMany transform esym let level = calcEllipsisLevel nextHasEllipsis ellipsisLevel let idx = calcEllipsisIndex nextHasEllipsis level ellipsisIndex- if (nextHasEllipsis)+ if nextHasEllipsis then do- curT <- transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers level idx (List []) (List l)- case (curT) of+ curT <- transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers esym level idx (List []) (List l)+ case curT of Nil _ -> -- No match ("zero" case). Use tail to move past the "..." continueTransform defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers + esym ellipsisLevel (init ellipsisIndex) -- Issue #56 - done w/ellip so no need for last idx result $ tail ts List _ -> transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers + esym 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 divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List []) (List l)+ lst <- transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers esym ellipsisLevel ellipsisIndex (List []) (List l) case lst of- List _ -> transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List $ result ++ [lst]) (List ts)+ List _ -> transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers esym 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 divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List result) transform@(List ((Vector v) : ts)) = do- let nextHasEllipsis = macroElementMatchesMany transform+transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers esym ellipsisLevel ellipsisIndex (List result) transform@(List ((Vector v) : ts)) = do+ let nextHasEllipsis = macroElementMatchesMany transform esym 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 divertEnv localEnv renameEnv cleanupEnv dim identifiers level idx (List []) (List $ elems v)+ curT <- transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers esym 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 divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel (init ellipsisIndex) result $ tail ts+ continueTransform defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers esym ellipsisLevel (init ellipsisIndex) result $ tail ts List t -> transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers + esym 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 divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List []) (List $ elems v)+ else do lst <- transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers esym ellipsisLevel ellipsisIndex (List []) (List $ elems v) case lst of- List l -> transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List $ result ++ [asVector l]) (List ts)+ List l -> transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers esym 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 divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List result) transform@(List (dl@(DottedList _ _) : ts)) = do- let nextHasEllipsis = macroElementMatchesMany transform+transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers esym ellipsisLevel ellipsisIndex (List result) transform@(List (dl@(DottedList _ _) : ts)) = do+ let nextHasEllipsis = macroElementMatchesMany transform esym 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 defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers level idx (List []) (List [dl])+ curT <- transformDottedList defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers esym level idx (List []) (List [dl]) case curT of Nil _ -> -- No match ("zero" case). Use tail to move past the "..."- continueTransform defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel (init ellipsisIndex) result $ tail ts + continueTransform defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers esym ellipsisLevel (init ellipsisIndex) result $ tail ts List t -> transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers + esym 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 divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List []) (List [dl])+ else do lst <- transformDottedList defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers esym ellipsisLevel ellipsisIndex (List []) (List [dl]) case lst of- List l -> transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List $ result ++ l) (List ts)+ List l -> transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers esym ellipsisLevel ellipsisIndex (List $ result ++ l) (List ts) Nil _ -> return lst _ -> throwError $ BadSpecialForm "transformRule: Macro transform error" $ List [lst, (List [dl]), Number $ toInteger ellipsisLevel] @@ -1122,7 +1135,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 divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List result) transform@(List (Atom a : ts)) = do+transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers esym 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 @@ -1146,7 +1159,7 @@ -- case this is allowed) or when an ellipsis is present in the actual macro (which -- should be an error). --- transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List $ result ++ [expanded]) (List $ tail ts)+ transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers esym 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@@ -1168,7 +1181,7 @@ Just b -> return b Nothing -> return $ Bool False - hasEllipsis = macroElementMatchesMany transform+ hasEllipsis = macroElementMatchesMany transform esym ellipsisHere isDefined = do if isDefined then do @@ -1179,15 +1192,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 divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List $ result ++ aa) (List $ tail ts)+ List aa -> transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers esym ellipsisLevel ellipsisIndex (List $ result ++ aa) (List $ tail ts) _ -> -- No matches for var- continueTransform defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex result $ tail ts+ continueTransform defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers esym ellipsisLevel ellipsisIndex result $ tail ts Nil "" -> -- No matches, keep going- 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)+ continueTransform defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers esym ellipsisLevel ellipsisIndex result $ tail ts+ v@(_) -> transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers esym ellipsisLevel ellipsisIndex (List $ result ++ [v]) (List $ tail ts) else -- Matched 0 times, skip it- transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List result) (List $ tail ts)+ transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers esym ellipsisLevel ellipsisIndex (List result) (List $ tail ts) noEllipsis isDefined = do isImproperPattern <- loadNamespacedBool 'p' -- "improper pattern"@@ -1271,17 +1284,18 @@ transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers + esym ellipsisLevel ellipsisIndex (List $ results) (List ts) -- Transform anything else as itself...-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) +transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers esym ellipsisLevel ellipsisIndex (List result) (List (t : ts)) = do+ transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers esym 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@@ -1290,7 +1304,7 @@ -- 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 divertEnv localEnv renameEnv _ dim identifiers _ _ _ (Atom transform) = do+transformRule defEnv outerEnv divertEnv localEnv renameEnv _ dim identifiers esym _ _ _ (Atom transform) = do Bool isIdent <- findAtom (Atom transform) identifiers isPattVar <- liftIO $ isRecBound localEnv transform if isPattVar && not isIdent@@ -1299,7 +1313,7 @@ -- 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 -> Env -> Bool -> String -> IOThrowsError LispVal@@ -1346,9 +1360,9 @@ -} -- | A helper function for transforming an improper list-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)+transformDottedList :: Env -> Env -> Env -> Env -> Env -> Env -> Bool -> LispVal -> String -> Int -> [Int] -> LispVal -> LispVal -> IOThrowsError LispVal+transformDottedList defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers esym ellipsisLevel ellipsisIndex (List result) (List (DottedList ds d : ts)) = do+ lsto <- transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers esym ellipsisLevel ellipsisIndex (List []) (List ds) case lsto of List lst -> do -- Similar logic to the parser is applied here, where@@ -1357,18 +1371,19 @@ -- -- d is an n-ary match, per Issue #34 r <- transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers + esym ellipsisLevel -- OK not to increment here, this is accounted for later on ellipsisIndex -- Same as above (List []) - (List [d, Atom "..."])+ (List [d, Atom esym]) case r of -- Trailing symbol in the pattern may be neglected in the transform, so skip it... List [] ->- transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List $ result ++ [List lst]) (List ts)+ transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers esym ellipsisLevel ellipsisIndex (List $ result ++ [List lst]) (List ts) Nil _ -> -- Same as above, no match for d, so skip it - transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List $ result ++ [List lst]) (List ts)+ transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers esym ellipsisLevel ellipsisIndex (List $ result ++ [List lst]) (List ts) List rst -> do- transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex + transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers esym ellipsisLevel ellipsisIndex (buildTransformedCode result lst rst) (List ts) _ -> throwError $ BadSpecialForm "Macro transform error processing pair" $ DottedList ds d Nil _ -> return $ Nil ""@@ -1391,16 +1406,17 @@ 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 -> Env -> Bool -> LispVal -> Int -> [Int] -> [LispVal] -> [LispVal] -> IOThrowsError LispVal-continueTransform defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex result remaining = do+continueTransform :: Env -> Env -> Env -> Env -> Env -> Env -> Bool -> LispVal -> String -> Int -> [Int] -> [LispVal] -> [LispVal] -> IOThrowsError LispVal+continueTransform defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers esym ellipsisLevel ellipsisIndex result remaining = do if not (null remaining) then transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers+ esym ellipsisLevel ellipsisIndex (List result) @@ -1456,12 +1472,24 @@ (List [Atom keyword, (List (Atom "syntax-rules" : + Atom ellipsis : (List identifiers : rules)))] : bs) = do _ <- defineNamespacedVar be macroNamespace keyword $ - Syntax (Just e) Nothing dim identifiers rules+ Syntax (Just e) Nothing dim ellipsis identifiers rules loadMacros e be Nothing dim bs +-- Standard processing for a syntax-rules transformer+loadMacros e be Nothing dim + (List + [Atom keyword, + (List (Atom "syntax-rules" : + (List identifiers : rules)))] : + bs) = do+ _ <- defineNamespacedVar be macroNamespace keyword $ + Syntax (Just e) Nothing dim "..." identifiers rules+ loadMacros e be Nothing dim bs+ -- Standard processing for an explicit renaming transformer loadMacros e be Nothing dim (List @@ -1486,6 +1514,12 @@ case (exSynRules, spec) of (Atom "syntax-rules", + (Atom ellipsis :+ (List identifiers : rules))) -> do+ _ <- defineNamespacedVar be macroNamespace exKeyword $ + Syntax (Just e) (Just re) dim ellipsis identifiers rules+ loadMacros e be (Just re) dim bs+ (Atom "syntax-rules", (List identifiers : rules)) -> do -- -- Temporary hack to expand the rules -- List exRules <- cleanExpanded e e e re re dim False False (List []) (List rules)@@ -1494,7 +1528,7 @@ _ <- defineNamespacedVar be macroNamespace exKeyword $ -- Syntax (Just e) (Just re) dim identifiers (trace ("exRules = " ++ show exRules) exRules) --rules -- Syntax (Just e) (Just re) dim identifiers exRules --rules- Syntax (Just e) (Just re) dim identifiers rules+ Syntax (Just e) (Just re) dim "..." identifiers rules loadMacros e be (Just re) dim bs -- -- TODO: should check for lambda instead of _
hs-src/Language/Scheme/Primitives.hs view
@@ -21,11 +21,15 @@ car , cdr , cons+ , eq , equal + , makeList+ , listCopy -- ** Vector , buildVector , vectorLength , vectorRef + , vectorCopy , vectorToList , listToVector , makeVector@@ -62,6 +66,8 @@ , stringToNumber , stringToList , listToString+ , stringToVector+ , vectorToString , stringCopy , symbol2String , string2Symbol@@ -138,9 +144,10 @@ import qualified Data.ByteString.UTF8 as BSU import Data.Char hiding (isSymbol) import Data.Array-import Data.Unique+--import qualified Data.List as DL import qualified Data.Map import qualified Data.Time.Clock.POSIX+import Data.Unique import Data.Word import qualified System.Cmd import System.Directory (doesFileExist, removeFile)@@ -504,6 +511,53 @@ cons [x1, x2] = return $ DottedList [x1] x2 cons badArgList = throwError $ NumArgs (Just 2) badArgList +makeList :: [LispVal] -> ThrowsError LispVal+makeList [(Number n)] = makeList [Number n, List []]+makeList [(Number n), a] = do+ let l = replicate (fromInteger n) a+ return $ List l+makeList [badType] = throwError $ TypeMismatch "integer" badType+makeList badArgList = throwError $ NumArgs (Just 1) badArgList++listCopy :: [LispVal] -> IOThrowsError LispVal+listCopy [p@(Pointer _ _)] = do+ l <- derefPtr p+ listCopy [l]+listCopy [(List ls)] = return $ List ls+listCopy [badType] = return badType+listCopy badArgList = throwError $ NumArgs (Just 1) badArgList++vectorCopy :: [LispVal] -> IOThrowsError LispVal+vectorCopy (p@(Pointer _ _) : args) = do+ v <- derefPtr p+ vectorCopy (v : args)+vectorCopy [Vector vs] = do+ let l = elems vs+ return $ Vector $ listArray (0, length l - 1) l +vectorCopy [Vector vs, Number start] = do+ let l = drop (fromInteger start) $ + elems vs+ return $ Vector $ listArray (0, length l - 1) l +vectorCopy [Vector vs, Number start, Number end] = do+ let l = take (fromInteger $ end - start) $+ drop (fromInteger start) $ + elems vs+ return $ Vector $ listArray (0, length l - 1) l +vectorCopy [badType] = return badType+vectorCopy badArgList = throwError $ NumArgs (Just 1) badArgList++-- | Use pointer equality to compare two objects if possible, otherwise+-- fall back to the normal equality comparison+eq :: [LispVal] -> IOThrowsError LispVal+eq [(Pointer pA envA), (Pointer pB envB)] = do+ if pA == pB + then do+ refA <- getNamespacedRef envA varNamespace pA+ refB <- getNamespacedRef envB varNamespace pB+ return $ Bool $ refA == refB+ else return $ Bool False+eq args = recDerefToFnc eqv args+ -- | Recursively compare two LispVals for equality -- -- Arguments:@@ -1166,6 +1220,23 @@ listToString [] = throwError $ NumArgs (Just 1) [] listToString args@(_ : _) = throwError $ NumArgs (Just 1) args +stringToVector :: [LispVal] -> IOThrowsError LispVal+stringToVector args = do+ List l <- stringToList args+ return $ Vector $ listArray (0, length l - 1) l+vectorToString :: [LispVal] -> IOThrowsError LispVal+vectorToString [p@(Pointer _ _)] = derefPtr p >>= box >>= listToString+--vectorToString [(List [])] = return $ String ""+--vectorToString [(List l)] = liftThrows $ buildString l+vectorToString [(Vector v)] = do+ let l = elems v+ case l of+ [] -> return $ String ""+ _ -> liftThrows $ buildString l+vectorToString [badType] = throwError $ TypeMismatch "vector" badType+vectorToString [] = throwError $ NumArgs (Just 1) []+vectorToString args@(_ : _) = throwError $ NumArgs (Just 1) args+ -- | Create a copy of the given string -- -- Arguments:@@ -1175,8 +1246,17 @@ -- Returns: String - New copy of the given string -- stringCopy :: [LispVal] -> IOThrowsError LispVal-stringCopy [p@(Pointer _ _)] = derefPtr p >>= box >>= stringCopy+stringCopy (p@(Pointer _ _) : args) = do+ s <- derefPtr p + stringCopy (s : args) stringCopy [String s] = return $ String s+stringCopy [String s, Number start] = do+ return $ String $ + drop (fromInteger start) s+stringCopy [String s, Number start, Number end] = do+ return $ String $ + take (fromInteger $ end - start) $+ drop (fromInteger start) s stringCopy [badType] = throwError $ TypeMismatch "string" badType stringCopy badArgList = throwError $ NumArgs (Just 2) badArgList
hs-src/Language/Scheme/Types.hs view
@@ -67,6 +67,7 @@ , synClosure , synRenameClosure , synDefinedInMacro+ , synEllipsis , synIdentifiers , synRules , SyntaxExplicitRenaming@@ -246,6 +247,7 @@ , synRenameClosure :: Maybe Env -- ^ Renames (from macro hygiene) in effect at def time; -- only applicable if this macro defined inside another macro. , synDefinedInMacro :: Bool -- ^ Set if macro is defined within another macro+ , synEllipsis :: String -- ^ String to use as the ellipsis identifier , 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.@@ -446,7 +448,7 @@ showVal (DottedList h t) = "(" ++ unwordsList h ++ " . " ++ showVal t ++ ")" showVal (PrimitiveFunc _) = "<primitive>" showVal (Continuation _ _ _ _ _) = "<continuation>"-showVal (Syntax _ _ _ _ _) = "<syntax>"+showVal (Syntax _ _ _ _ _ _) = "<syntax>" showVal (SyntaxExplicitRenaming _) = "<er-macro-transformer syntax>" showVal (Func {params = args, vararg = varargs, body = _, closure = _}) = "(lambda (" ++ unwords args ++@@ -527,9 +529,9 @@ -> m LispVal makeHVarargs = makeHFunc . Just . showVal --- |Validate that function parameters consist of a list of --- non-duplicate symbols.+-- |Validate formal function parameters. validateFuncParams :: [LispVal] -> Maybe Integer -> IOThrowsError Bool+--validateFuncParams [Atom _] _ = return True validateFuncParams ps (Just n) = do if length ps /= fromInteger n then throwError $ NumArgs (Just n) ps
hs-src/Language/Scheme/Variables.hs view
@@ -34,6 +34,7 @@ , getVar' , getNamespacedVar , getNamespacedVar' + , getNamespacedRef -- * Setters , defineVar , defineNamespacedVar@@ -49,6 +50,7 @@ , derefPtr -- , derefPtrs , recDerefPtrs+ , recDerefToFnc ) where import Language.Scheme.Types import Control.Monad.Error@@ -270,6 +272,20 @@ -> IOThrowsError (Maybe LispVal) -- ^ Contents of the variable getVar' envRef var = getNamespacedVar' envRef varNamespace var +-- |Retrieve an ioRef defined in a given namespace+getNamespacedRef :: Env -- ^ Environment+ -> Char -- ^ Namespace+ -> String -- ^ Variable+ -> IOThrowsError (IORef LispVal)+getNamespacedRef envRef+ namespace+ var = do+ let fnc io = return io+ v <- getNamespacedObj' envRef namespace var fnc+ case v of+ Just a -> return a+ Nothing -> (throwError $ UnboundVar "Getting an unbound variable" var)+ -- |Retrieve the value of a variable defined in a given namespace getNamespacedVar :: Env -- ^ Environment -> Char -- ^ Namespace@@ -292,13 +308,25 @@ getNamespacedVar' envRef namespace var = do + getNamespacedObj' envRef namespace var fnc+ where fnc io = readIORef io++getNamespacedObj' :: Env -- ^ Environment+ -> Char -- ^ Namespace+ -> String -- ^ Variable+ -> (IORef LispVal -> IO a)+ -> IOThrowsError (Maybe a) -- ^ Contents of the variable, if found+getNamespacedObj' envRef+ namespace+ var + unpackFnc = do binds <- liftIO $ readIORef $ bindings envRef case Data.Map.lookup (getVarName namespace var) binds of (Just a) -> do- v <- liftIO $ readIORef a+ v <- liftIO $ unpackFnc a return $ Just v Nothing -> case parentEnv envRef of- (Just par) -> getNamespacedVar' par namespace var+ (Just par) -> getNamespacedObj' par namespace var unpackFnc Nothing -> return Nothing -- |Set a variable in the default namespace@@ -589,6 +617,14 @@ result <- getVar env p recDerefPtrs result recDerefPtrs v = return v++-- |A helper to recursively dereference all pointers and+-- pass results to a function+recDerefToFnc :: ([LispVal] -> ThrowsError LispVal) -> [LispVal] + -> IOThrowsError LispVal+recDerefToFnc fnc lvs = do+ List result <- recDerefPtrs $ List lvs + liftThrows $ fnc result -- |A predicate to determine if the given lisp value -- is an "object" that can be pointed to.
husk-scheme.cabal view
@@ -1,5 +1,5 @@ Name: husk-scheme-Version: 3.12+Version: 3.13 Synopsis: R5RS Scheme interpreter, compiler, and library. Description: <<https://github.com/justinethier/husk-scheme/raw/master/docs/husk-scheme.png>>@@ -42,7 +42,7 @@ ChangeLog.markdown LICENSE AUTHORS-Data-Files: lib/*.scm lib/husk/*.sld lib/husk/*.scm lib/scheme/*.sld lib/scheme/r5rs/*.sld lib/srfi/*.scm+Data-Files: lib/*.scm lib/husk/*.sld lib/husk/*.scm lib/scheme/*.sld lib/srfi/*.scm Source-Repository head Type: git@@ -65,6 +65,7 @@ Extensions: ExistentialQuantification Hs-Source-Dirs: hs-src Exposed-Modules: Language.Scheme.Core+ Language.Scheme.Environments Language.Scheme.Types Language.Scheme.Variables Language.Scheme.Compiler
+ lib/core.scm view
@@ -0,0 +1,557 @@+;;;+;;; husk-scheme+;;; http://justinethier.github.com/husk-scheme+;;;+;;; Written by Justin Ethier+;;;+;;; Standard library of scheme functions+;;;++(define call/cc call-with-current-continuation)++(define (not x) (if x #f #t))++(define (list . objs) objs)+(define (id obj) obj)++; TODO: this is not flipping args. not part of R5RS, but +; as it is now, what is the point?+(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))))++(define (foldr func end lst)+ (if (null? lst)+ end+ (func (car lst) (foldr func end (cdr lst)))))++(define (foldl func accum lst)+ (if (null? lst)+ accum+ (foldl func (func (car lst) accum) (cdr lst))))++(define (sum . lst) (foldl + 0 lst))+(define (product . lst) (foldl * 1 lst))++; Forms from R5RS for and/or+(define-syntax and+ (syntax-rules ()+ ((and) #t)+ ((and test) test)+ ((and test1 test2 ...)+ (if test1 (and test2 ...) #f))))++(define-syntax or+ (syntax-rules ()+ ((or) #f)+ ((or test) test)+ ((or test1 test2 ...)+ (let ((x test1))+ (if x x (or test2 ...))))))++(define (abs num)+ (if (negative? num)+ (* num -1)+ num))++(define (max first . rest) (foldl (lambda (old new) (if (> old new) old new)) first rest))+(define (min first . rest) (foldl (lambda (old new) (if (< old new) old new)) first rest))++(define zero? (curry = 0))+(define positive? (curry < 0))+(define negative? (curry > 0))+(define (odd? num) (= (modulo num 2) 1))+(define (even? num) (= (modulo num 2) 0))++(define (length lst) (foldl (lambda (x y) (+ y 1)) 0 lst))+(define (reverse lst) (foldl (flip cons) '() lst))++(define-syntax begin+ (syntax-rules ()+ ((begin exp ...)+ ((lambda () exp ...)))))++;+;+; NOTE: The below cond/case forms do NOT use begin to prevent+; conflicts between the stdlib begin and the begin form+; from the module metalanguage.+;+; TODO: this may indicate a problem with syntax-rules and+; referential transparency.+;+;++; cond+; Form from R5RS:+(define-syntax cond+ (syntax-rules (else =>)+ ((cond (else result1 result2 ...))+;+; TODO: see pitfall 3.2+;+; This is a modification from R5RS - we put the begin within+; an if statement, because in this context definitions are+; not allowed. This prevents one from interfering with macro+; hygiene. +;+; TODO: unfortunately the macro logic has not yet been+; updated to take this into acccount, so the pitfall+; still fails+;+ ((lambda () result1 result2 ...))) ;; Intentionally not using begin, see above+ ((cond (test => result))+ (let ((temp test))+ (if temp (result temp))))+ ((cond (test => result) clause1 clause2 ...)+ (let ((temp test))+ (if temp+ (result temp)+ (cond clause1 clause2 ...))))+ ((cond (test)) test)+ ((cond (test) clause1 clause2 ...)+ (let ((temp test))+ (if temp+ temp+ (cond clause1 clause2 ...))))+ ((cond (test result1 result2 ...))+ (if test ((lambda () result1 result2 ...)))) ;; Intentionally not using begin, see above+ ((cond (test result1 result2 ...)+ clause1 clause2 ...)+ (if test+ ((lambda () result1 result2 ...)) ;; Intentionally not using begin, see above+ (cond clause1 clause2 ...)))))+; Case+; Form from R5RS:+(define-syntax case+ (syntax-rules (else)+ ((case (key ...)+ clauses ...)+ (let ((atom-key (key ...)))+ (case atom-key clauses ...)))+ ((case key+ (else result1 result2 ...))+ (if #t ((lambda () result1 result2 ...)))) ;; Intentionally not using begin, see above+ ((case key+ ((atoms ...) result1 result2 ...))+ (if (memv key '(atoms ...))+ ((lambda () result1 result2 ...)))) ;; Intentionally not using begin, see above+ ((case key+ ((atoms ...) result1 result2 ...)+ clause clauses ...)+ (if (memv key '(atoms ...))+ ((lambda () result1 result2 ...)) ;; Intentionally not using begin, see above+ (case key clause clauses ...)))))++(define (my-mem-helper obj lst cmp-proc)+ (cond + ((null? lst) #f)+ ((cmp-proc obj (car lst)) lst)+ (else (my-mem-helper obj (cdr lst) cmp-proc))))+(define (memq obj lst) (my-mem-helper obj lst eq?))+(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 (next acc) (if (and (not acc) (pred (op next))) next acc)))+(define (assq obj alist) (foldl (mem-helper (curry eq? obj) car) #f alist))+(define (assv obj alist) (foldl (mem-helper (curry eqv? obj) car) #f alist))+(define (assoc obj alist) (foldl (mem-helper (curry equal? obj) car) #f alist))++; SRFI 8+; Reference implementation from: http://srfi.schemers.org/srfi-8/srfi-8.html+;+; FUTURE: This may be moved into its own file+;+(define-syntax receive+ (syntax-rules ()+ ((receive formals expression body ...)+ (call-with-values (lambda () expression)+ (lambda formals body ...)))))+; END SRFI 8++; Added the following support functions from SRFI 1+(define (car+cdr pair) (values (car pair) (cdr pair)))+(define (%cars+cdrs lists)+ (call-with-current-continuation+ (lambda (abort)+ (let recur ((lists lists))+ (if (pair? lists)+ (receive (list other-lists) (car+cdr lists)+ (if (null? list) (abort '() '()) ; LIST is empty -- bail out+ (receive (a d) (car+cdr list)+ (receive (cars cdrs) (recur other-lists)+ (values (cons a cars) (cons d cdrs))))))+ (values '() '()))))))+; END support functions++(define (map f lis1 . lists)+; (check-arg procedure? f map-in-order)+ (if (pair? lists)+ (let recur ((lists (cons lis1 lists)))+ (receive (cars cdrs) (%cars+cdrs lists)+ (if (pair? cars)+ (let ((x (apply f cars))) ; Do head first,+ (cons x (recur cdrs))) ; then tail.+ '())))+ ;; Fast path.+ (foldr (lambda (x y) (cons (f x) y)) '() lis1)))++(define (for-each f lis1 . lists)+ (if (pair? lists)+ (let recur ((lists (cons lis1 lists)))+ (receive (cars cdrs) (%cars+cdrs lists)+ (if (pair? cars)+ (begin+ (apply f cars)+ (recur cdrs)))))+ ;; Fast path.+ (if (eq? 1 (length lis1))+ (f (car lis1))+ (begin (f (car lis1))+ (for-each f (cdr lis1))))))++(define (list-tail lst k) + (if (zero? k)+ lst+ (list-tail (cdr lst) (- k 1))))+(define (list-ref lst k) (car (list-tail lst k)))++; Let forms+;+; letrec from R5RS+(define-syntax letrec+ (syntax-rules ()+ ((letrec ((var1 init1) ...) body ...)+ (letrec "generate_temp_names"+ (var1 ...)+ ()+ ((var1 init1) ...)+ body ...))+ ((letrec "generate_temp_names"+ ()+ (temp1 ...)+ ((var1 init1) ...)+ body ...) ; start the changed code+ (let ((var1 #f) ...)+ (let ((temp1 init1) ...)+ (set! var1 temp1)+ ...+ body ...)))+ ((letrec "generate_temp_names"+ (x y ...)+ (temp ...)+ ((var1 init1) ...)+ body ...)+ (letrec "generate_temp_names"+ (y ...)+ (newtemp temp ...)+ ((var1 init1) ...)+ body ...))))++; let and named let (using the Y-combinator):+(define-syntax let+ (syntax-rules ()+ ((_ ((x v) ...) e1 e2 ...)+ ((lambda (x ...) e1 e2 ...) v ...))+ ((_ name ((x v) ...) e1 e2 ...)+ (let*+ ((f (lambda (name)+ (lambda (x ...) e1 e2 ...)))+ (ff ((lambda (proc) (f (lambda (x ...) ((proc proc)+ x ...))))+ (lambda (proc) (f (lambda (x ...) ((proc proc)+ x ...)))))))+ (ff v ...)))))++;+; It would be nice to change first rule back to:+; ((_ () body) body)+;+(define-syntax let*+ (syntax-rules ()+ ((let* () body1 body2 ...)+ (let () body1 body2 ...))+ ((let* ((name1 val1) (name2 val2) ...)+ body1 body2 ...)+ (let ((name1 val1))+ (let* ((name2 val2) ...)+ body1 body2 ...)))))++; Iteration - do+(define-syntax do+ (syntax-rules ()+ ((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)))++; End delayed evaluation section++; String Section+(define-syntax string-fill!+ (syntax-rules ()+ ((_ _str _chr)+ (set! _str+ (make-string (string-length _str) _chr)))))++(define (string-concatenate l) + (apply string-append l)) ++; Vector Section+(define-syntax vector-fill!+ (syntax-rules ()+ ((_ _vec _fill)+ (set! _vec+ (make-vector (vector-length _vec) _fill)))))++; Bytevector Section++; TODO: add appropriate overloads, also note this is not the+; fastest implementation+(define (bytevector-copy! to at from start end)+ (do ((i 0 (+ i 1)))+ ((= i (- end start)))+ (bytevector-u8-set! + to+ (+ at i) + (bytevector-u8-ref from (+ start i)))))++; Continuation Section+(define (values . things)+ (call-with-current-continuation + (lambda (cont) (apply cont things))))++;; I/O Section+(define (newline . port)+ (if (null? port) + (display #\newline) + (display #\newline port)))++; TODO: test these forms+(define (call-with-input-file filename proc)+ (let ((opened-file (open-input-file filename)))+ (define result+ (proc opened-file))+ (close-input-port opened-file)+ result))+; TODO: test+(define (call-with-output-file filename proc)+ (let ((opened-file (open-output-file filename)))+ (define result+ (proc opened-file))+ (close-output-port opened-file)+ result))++;; SRFI 23 - Error reporting mechanism+;; based on code from: http://srfi.schemers.org/srfi-23/srfi-23.html+(define (error reason . args)+ (display "Error: ")+ (display reason)+ (newline)+ (for-each (lambda (arg) + (display " ")+ (write arg))+ args)+ (newline)+ (exit-fail))++;; Hashtable derived forms+(define hash-table-walk+ (lambda (ht proc)+ (map + (lambda (kv) (proc (car kv) (car (reverse kv))))+ (hash-table->alist ht)))) ++(define (hash-table-update! hash-table key function)+ (hash-table-set! hash-table key+ (function (hash-table-ref hash-table key))))++(define-syntax hash-table-merge!+ (syntax-rules ()+ ((_ hdest hsrc)+ (map (lambda (node) (hash-table-set! hdest + (car node)+ (cadr node)))+ (hash-table->alist hsrc)))))++(define (alist->hash-table lst)+ (let ((ht (make-hash-table)))+ (for-each (lambda (node)+ (hash-table-set! ht (car node) (cadr node)))+ lst)+ ht))++(define (hash-table-fold hash-table f acc-in)+ (let ((acc acc-in))+ (hash-table-walk hash-table + (lambda (key value) (set! acc (f key value acc))))+ acc))++; Implementations of gcd and lcm using Euclid's algorithm+;+; Also note that each form is written to accept either 0 or+; 2 arguments, per R5RS. This could probably be generalized+; even further, if necessary.+;+(define gcd '())+(define lcm '())++(let ()+ ; Main GCD algorithm+ (define (gcd/main a b)+ (if (= b 0)+ (abs a)+ (gcd/main b (modulo a b))))++ ; A helper function to reduce the input list+ (define (gcd/entry . nums)+ (if (eqv? nums '())+ 0+ (foldl gcd/main (car nums) (cdr nums))))++ ; Main LCM algorithm+ (define (lcm/main a b)+ (abs (/ (* a b) (gcd/main a b))))++ ; A helper function to reduce the input list+ (define (lcm/entry . nums)+ (if (eqv? nums '())+ 1+ (foldl lcm/main (car nums) (cdr nums))))++ (set! gcd gcd/entry)+ (set! lcm lcm/entry)) ++; append accepts a variable number of arguments, per R5RS. So a wrapper+; has been provided for the standard 2-argument version of (append).+;+; We return the given value if less than 2 arguments are given, and+; otherwise fold over each arg, appending it to its predecessor. +(define (append . lst)+ (define append-2+ (lambda (inlist alist) + (foldr (lambda (ap in) (cons ap in)) alist inlist)))+ (if (null? lst)+ lst+ (if (null? (cdr lst))+ (car lst)+ (foldl (lambda (a b) (append-2 b a)) (car lst) (cdr lst)))))++; Quasi-quotation as a macro+; Based on code from chibi-scheme+;+; The code below is compiled to avoid having to expand dozens of macros+; in real-time, significantly improving performance. This does highlight+; an area that husk could improve upon but for now a compilation will do.+;+; The (expand) special form is used to compile the code, in case it needs+; to be changed in the future.+;+(define-syntax quasiquote+ (er-macro-transformer+ (lambda (expr rename compare)+(define (qq x d) (if (pair? x) ((lambda () (if (compare (rename (quote unquote)) (car x)) ((lambda () (if (<= d 0) (cadr x) (list (rename (quote list)) (list (rename (quote quote)) (quote unquote)) (qq (cadr x) (- d 1)))))) (if (compare (rename (quote unquote-splicing)) (car x)) ((lambda () (if (<= d 0) (list (rename (quote cons)) (qq (car x) d) (qq (cdr x) d)) (list (rename (quote list)) (list (rename (quote quote)) (quote unquote-splicing)) (qq (cadr x) (- d 1)))))) (if (compare (rename (quote quasiquote)) (car x)) ((lambda () (list (rename (quote list)) (list (rename (quote quote)) (quote quasiquote)) (qq (cadr x) (+ d 1))))) (if (if (<= d 0) (if (pair? (car x)) (compare (rename (quote unquote-splicing)) (caar x)) #f) #f) ((lambda () (if (null? (cdr x)) (cadr (car x)) (list (rename (quote append)) (cadr (car x)) (qq (cdr x) d))))) (if #t ((lambda () (list (rename (quote cons)) (qq (car x) d) (qq (cdr x) d))))))))))) (if (vector? x) ((lambda () (list (rename (quote list->vector)) (qq (vector->list x) d)))) (if (if (symbol? x) #t (null? x)) ((lambda () (list (rename (quote quote)) x))) (if #t ((lambda () x)))))))+ (qq (cadr expr) 0))))+;; Original code:+; (define (qq x d)+; (cond+; ((pair? x)+; (cond+; ((compare (rename 'unquote) (car x))+; (if (<= d 0)+; (cadr x)+; (list (rename 'list) (list (rename 'quote) 'unquote)+; (qq (cadr x) (- d 1)))))+; ((compare (rename 'unquote-splicing) (car x))+; (if (<= d 0)+; (list (rename 'cons) (qq (car x) d) (qq (cdr x) d))+; (list (rename 'list) (list (rename 'quote) 'unquote-splicing)+; (qq (cadr x) (- d 1)))))+; ((compare (rename 'quasiquote) (car x))+; (list (rename 'list) (list (rename 'quote) 'quasiquote)+; (qq (cadr x) (+ d 1))))+; ((and (<= d 0) (pair? (car x))+; (compare (rename 'unquote-splicing) (caar x)))+; (if (null? (cdr x))+; (cadr (car x))+; (list (rename 'append) (cadr (car x)) (qq (cdr x) d))))+; (else+; (list (rename 'cons) (qq (car x) d) (qq (cdr x) d)))))+; ((vector? x) (list (rename 'list->vector) (qq (vector->list x) d)))+; ((if (symbol? x) #t (null? x)) (list (rename 'quote) x))+; (else x)))+; (qq (cadr expr) 0))))+++;;+;; Vector functions from r7rs+;; These help round-out the standard list/vector/string functions+(define (vector-map fnc . vargs)+ (let* ((ls (map (lambda (v) (vector->list v)) vargs)))+ (list->vector + (apply map + (cons fnc ls)))))++(define (vector-for-each fnc . vargs)+ (let ((ls (map (lambda (v) (vector->list v)) vargs)))+ (apply for-each + (cons fnc ls))))++(define (vector-append . vargs)+ (let ((ls (map (lambda (v) (vector->list v)) vargs)))+ (list->vector + (apply append + ls))))+(define (vector->string v)+ (list->string + (vector->list v)))++(define (string->vector s)+ (list->vector+ (string->list s)))+;;+;; String functions from r7rs+(define (string-map fnc . sargs)+ (let* ((ls (map (lambda (s) (string->list s)) sargs)))+ (list->string + (apply map + (cons fnc ls)))))+(define (string-for-each fnc . sargs)+ (let ((ls (map (lambda (v) (string->list v)) sargs)))+ (apply for-each + (cons fnc ls))))+;; END++;; More functions from r7rs+(define-syntax def-copy-in-place+ (er-macro-transformer+ (lambda (expr rename compare)+ (let* ((base (symbol->string (cadr expr)))+ (sym (lambda (rstr)+ (string->symbol+ (string-append base "-" rstr)))))+ `(define (,(sym "copy!") to at from)+ (do ((i 0 (+ i 1)))+ ((= i (,(sym "length") from)) to)+ (,(sym "set!") to (+ at i) (,(sym "ref") from i))))))))+(def-copy-in-place string)+(def-copy-in-place vector)+;; END+
+ lib/cxr.scm view
@@ -0,0 +1,30 @@++(define (caar pair) (car (car pair)))+(define (cadr pair) (car (cdr pair)))+(define (cdar pair) (cdr (car pair)))+(define (cddr pair) (cdr (cdr pair)))+(define (caaar pair) (car (car (car pair))))+(define (caadr pair) (car (car (cdr pair))))+(define (cadar pair) (car (cdr (car pair))))+(define (caddr pair) (car (cdr (cdr pair))))+(define (cdaar pair) (cdr (car (car pair))))+(define (cdadr pair) (cdr (car (cdr pair))))+(define (cddar pair) (cdr (cdr (car pair))))+(define (cdddr pair) (cdr (cdr (cdr pair))))+(define (caaaar pair) (car (car (car (car pair)))))+(define (caaadr pair) (car (car (car (cdr pair)))))+(define (caadar pair) (car (car (cdr (car pair)))))+(define (caaddr pair) (car (car (cdr (cdr pair)))))+(define (cadaar pair) (car (cdr (car (car pair)))))+(define (cadadr pair) (car (cdr (car (cdr pair)))))+(define (caddar pair) (car (cdr (cdr (car pair)))))+(define (cadddr pair) (car (cdr (cdr (cdr pair)))))+(define (cdaaar pair) (cdr (car (car (car pair)))))+(define (cdaadr pair) (cdr (car (car (cdr pair)))))+(define (cdadar pair) (cdr (car (cdr (car pair)))))+(define (cdaddr pair) (cdr (car (cdr (cdr pair)))))+(define (cddaar pair) (cdr (cdr (car (car pair)))))+(define (cddadr pair) (cdr (cdr (car (cdr pair)))))+(define (cdddar pair) (cdr (cdr (cdr (car pair)))))+(define (cddddr pair) (cdr (cdr (cdr (cdr pair)))))+
+ lib/lazy.scm view
@@ -0,0 +1,25 @@+++; Delayed evaluation functions+(define force+ (lambda (object)+ (object)))++(define-syntax delay + (syntax-rules () + ((delay expression)+ (make-promise (lambda () expression)))))++(define make-promise+ (lambda (proc)+ (let ((result-ready? #f)+ (result #f))+ (lambda ()+ (if result-ready? + result+ (let ((x (proc)))+ (if result-ready?+ result+ (begin (set! result x)+ (set! result-ready? #t)+ result))))))))
lib/modules.scm view
@@ -15,6 +15,12 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; modules +; JAE - load necessary scheme libraries+; TODO: this is too much stuff (core), make this more specific+;(load "cxr.scm")+;(load "core.scm")+; END loading+ ;; Hacked version of this function req'd to get everything to work (define (identifier->symbol s) s)
lib/scheme/base.sld view
@@ -1,5 +1,256 @@-; TODO: This file is just a stub for-; future r7rs library support-;(define-library (scheme base)-; (export-all)-; (import (scheme)))+;; TODO: this is incomplete at the moment++;;;+;;; husk-scheme+;;; http://justinethier.github.com/husk-scheme+;;;+;;; Written by Justin Ethier+;;;+;;; r7rs-small base library+;;;++(define-library (scheme base)+; TODO: load scheme defs from another file?+; maybe good enough that that other file is part of (scheme)+ (export+ *+ ++ -+ /+ <+ <=+ =+ >+ >=+ abs+ and+ append+ apply+ assoc+ assq+ assv+ begin+ boolean?+ bytevector+ bytevector-append+ bytevector-copy+ bytevector-copy!+ bytevector-length+ bytevector-u8-ref+ bytevector?+ caar+ cadr+ call-with-current-continuation+ call-with-values+ call/cc+ car+ case+ cdar+ cddr+ cdr+ ceiling+ char->integer+ char-ready?+ char<=?+ char<?+ char=?+ char>=?+ char>?+ char?+ close-input-port+ close-output-port+ complex?+ cond+ cons+ current-input-port+ current-output-port+ denominator+ do+ dynamic-wind+ eof-object?+ eq?+ equal?+ eqv?+ error+ even?+ (rename inexact->exact exact)+ (rename exact->inexact inexact)+ expt+ floor+ for-each+ gcd+; JAE TODO: should import be included???+ ;import+ ;include+ ;include-ci+ input-port?+ integer->char+ integer?+ lcm+ length+ let+ let*+ letrec+ list+ list->string+ list->vector+ list-ref+ list-tail+ list?+ make-bytevector+ make-string+ make-vector+ map+ max+ member+ memq+ memv+ min+ modulo+ negative?+ newline+ not+ null?+ number->string+ number?+ numerator+ odd?+ or+ output-port?+ pair?+ peek-char+ positive?+ procedure?+ quasiquote+ quotient+ rational?+ rationalize+ read-char+ real?+ remainder+ reverse+ round+ string+ string->list+ string->number+ string->symbol+ string->utf8+ string-append+ string-copy+ string-length+ string-ref+ string<=?+ string<?+ string=?+ string>=?+ string>?+ string?+ substring+ symbol->string+ symbol?+ truncate+ utf8->string+ values+ vector+ vector->list+ vector-length+ vector-ref+ vector?+ write-char+ zero?++ ;=>+ ;binary-port?+ ;boolean=?+ ;bytevector-u8-set!+ ;call-with-port+ ;close-port+ ;cond-expand+ ;current-error-port+ ;define+ ;define-record-type+ ;define-syntax+ ;define-values+ ;else+ ;eof-object+ ;error-object-irritants+ ;error-object-message+ ;error-object?+ ;exact-integer-sqrt+ ;exact-integer?+ ;exact?+ ;features+ ;file-error?+ ;floor-quotient+ ;floor-remainder+ ;floor/+ ;flush-output-port+ ;get-output-bytevector+ ;get-output-string+ ;guard+ ;if+ ;inexact?+ ;input-port-open?+ ;lambda+ ;let*-values+ ;let-syntax+ ;let-values+ ;letrec*+ ;letrec-syntax+ list-copy+ ;list-set!+ make-list+ ;make-parameter+ ;open-input-bytevector+ ;open-input-string+ ;open-output-bytevector+ ;open-output-string+ ;output-port-open?+ ;parameterize+ ;peek-u8+ ;port?+ ;quote+ ;raise+ ;raise-continuable+ ;read-bytevector+ ;read-bytevector!+ ;read-error?+ ;read-line+ ;read-string+ ;read-u8+ ;set!+ ;set-car!+ ;set-cdr!+ ;square+ string->vector+ string-copy!+ ;string-fill!+ string-for-each+ string-map+ ;string-set!+ ;symbol=?+ ;syntax-error+ ;syntax-rules+ ;textual-port?+ ;truncate-quotient+ ;truncate-remainder+ ;truncate/+ ;u8-ready?+ ;unless+ ;unquote+ ;unquote-splicing+ vector->string+ vector-append+ vector-copy+ vector-copy!+ ;vector-fill!+ vector-for-each+ vector-map+ ;vector-set!+ ;when+ ;with-exception-handler+ ;write-bytevector+ ;write-string+ ;write-u8+ )+ (import (scheme)))
+ lib/scheme/case-lambda.sld view
@@ -0,0 +1,43 @@+;;;+;;; husk-scheme+;;; http://justinethier.github.com/husk-scheme+;;;+;;; Written by Justin Ethier+;;;+;;; r7rs-small case-lambda library+;;;+++; TODO: this is the macro from the spec, but husk+; does not handle the let-syntax portion...++(define-library (scheme case-lambda)+ (export+ case-lambda)+ (import (scheme base))+ (begin+ (define-syntax case-lambda+ (syntax-rules ()+ ((case-lambda (params body0 ...) ...)+ (lambda args+ (let ((len (length args)))+ (let-syntax+ ((cl (syntax-rules ::: ()+ ((cl)+ (error "no matching clause"))+ ((cl ((p :::) . body) . rest)+ (if (= len (length '(p :::)))+ (apply (lambda (p :::)+ . body)+ args)+ (cl . rest)))+ ((cl ((p ::: . tail) . body)+ . rest)+ (if (>= len (length '(p :::)))+ (apply+ (lambda (p ::: . tail)+ . body)+ args)+ (cl . rest))))))+ (cl (params body0 ...) ...))))))) + ))
+ lib/scheme/char.sld view
@@ -0,0 +1,35 @@+;;;+;;; husk-scheme+;;; http://justinethier.github.com/husk-scheme+;;;+;;; Written by Justin Ethier+;;;+;;; r7rs-small char library+;;;++(define-library (scheme char)+ (export+ char-alphabetic?+ char-ci<=?+ char-ci<?+ char-ci=?+ char-ci>=?+ char-ci>?+ ;char-downcase+ ;char-foldcase+ char-lower-case?+ char-numeric?+ ;char-upcase+ char-upper-case?+ char-whitespace?+ ;digit-value+ string-ci<=?+ string-ci<?+ string-ci=?+ string-ci>=?+ string-ci>?+ ;string-downcase+ ;string-foldcase+ ;string-upcase+ )+ (import (scheme)))
+ lib/scheme/complex.sld view
@@ -0,0 +1,19 @@+;;;+;;; husk-scheme+;;; http://justinethier.github.com/husk-scheme+;;;+;;; Written by Justin Ethier+;;;+;;; r7rs complex library+;;;++(define-library (scheme complex)+ (export+ angle+ imag-part+ magnitude+ make-polar+ make-rectangular+ real-part+ )+ (import (scheme)))
+ lib/scheme/cxr.sld view
@@ -0,0 +1,37 @@+;;;+;;; husk-scheme+;;; http://justinethier.github.com/husk-scheme+;;;+;;; Written by Justin Ethier+;;;+;;; The cxr library from r7rs+;;;++(define-library (scheme cxr)+ (export+ caaaar+ caaadr+ caaar+ caadar+ caaddr+ caadr+ cadaar+ cadadr+ cadar+ caddar+ cadddr+ caddr+ cdaaar+ cdaadr+ cdaar+ cdadar+ cdaddr+ cdadr+ cddaar+ cddadr+ cddar+ cdddar+ cddddr+ cdddr)+ (include "../cxr.scm")+ (import (scheme base)))
+ lib/scheme/eval.sld view
@@ -0,0 +1,19 @@+;;;+;;; husk-scheme+;;; http://justinethier.github.com/husk-scheme+;;;+;;; Written by Justin Ethier+;;;+;;; r7rs eval library+;;;++(define-library (scheme eval)+ (export + eval+ ; environment+ ; TODO: not in r7rs, not sure proper place => current-environment+ ; TODO: this in in REPL - interaction-environment+ ; TODO: not in r7rs, not sure proper place => make-environment+ ; TODO: not in r7rs, not sure proper place => null-environment+ )+ (import (scheme)))
+ lib/scheme/file.sld view
@@ -0,0 +1,23 @@+;;;+;;; husk-scheme+;;; http://justinethier.github.com/husk-scheme+;;;+;;; Written by Justin Ethier+;;;+;;; r7rs file library+;;;++(define-library (scheme file)+ (export+ call-with-input-file+ call-with-output-file+ delete-file+ file-exists?+ ;TODO: open-binary-input-file+ ;TODO: open-binary-output-file+ open-input-file+ open-output-file+ ;TODO: with-input-from-file+ ;TODO: with-output-to-file+ )+ (import (scheme)))
+ lib/scheme/inexact.sld view
@@ -0,0 +1,25 @@+;;;+;;; husk-scheme+;;; http://justinethier.github.com/husk-scheme+;;;+;;; Written by Justin Ethier+;;;+;;; r7rs-small inexact library+;;;++(define-library (scheme inexact)+ (export+ acos+ asin+ atan+ cos+ exp+ ;TODO: finite?+ ;TODO: infinite?+ log+ ;TODO: nan?+ sin+ sqrt+ tan+ )+ (import (scheme)))
+ lib/scheme/lazy.sld view
@@ -0,0 +1,19 @@+;;;+;;; husk-scheme+;;; http://justinethier.github.com/husk-scheme+;;;+;;; Written by Justin Ethier+;;;+;;; r7rs lazy library+;;;++(define-library (scheme lazy)+ (export+ delay+ ;delay-force+ force+ make-promise+ ;promise?+ )+ (include "../lazy.scm")+ (import (scheme base)))
+ lib/scheme/load.sld view
@@ -0,0 +1,12 @@+;;;+;;; husk-scheme+;;; http://justinethier.github.com/husk-scheme+;;;+;;; Written by Justin Ethier+;;;+;;; r7rs load library+;;;++(define-library (scheme load)+ (export load)+ (import (scheme)))
+ lib/scheme/process-context.sld view
@@ -0,0 +1,20 @@+;;;+;;; husk-scheme+;;; http://justinethier.github.com/husk-scheme+;;;+;;; Written by Justin Ethier+;;;+;;; r7rs process-context library+;;;++(define-library (scheme process-context)+ (export ++; TODO:+; command-line+; emergency-exit+; exit+; get-environment-variable+; get-environment-variables+ )+ (import (scheme)))
+ lib/scheme/r5rs.sld view
@@ -0,0 +1,18 @@+;;;+;;; husk-scheme+;;; http://justinethier.github.com/husk-scheme+;;;+;;; Written by Justin Ethier+;;;+;;; r7rs-small r5rs library+;;;+++; TODO: well obviously this won't work, since it includes itself+; need a way to load r5rsEnv on demand. unfortunately the direct bindings+; null-env, etc are supposed to be in r5rs. so may need a husk-specific+; function to do it...+;+;(define-library (scheme r5rs)+; (export-all)+; (import (scheme r5rs)))
− lib/scheme/r5rs/base.sld
@@ -1,256 +0,0 @@-;;;-;;; husk-scheme-;;; http://justinethier.github.com/husk-scheme-;;;-;;; Written by Justin Ethier-;;;-;;; r5rs equivalent libraries-;;;-;;; This library exposes an R5RS equivalent to -;;; the corresponding R7RS-small library.-;;;--(define-library (scheme r5rs base)- (export- *- +- -- /- <- <=- =- >- >=- abs- and- append- apply- assoc- assq- assv- begin- boolean?- bytevector- bytevector-append- bytevector-copy- bytevector-copy!- bytevector-length- bytevector-u8-ref- bytevector?- caar- cadr- call-with-current-continuation- call-with-values- call/cc- car- case- cdar- cddr- cdr- ceiling- char->integer- char-ready?- char<=?- char<?- char=?- char>=?- char>?- char?- close-input-port- close-output-port- complex?- cond- cons- current-input-port- current-output-port- denominator- do- dynamic-wind- eof-object?- eq?- equal?- eqv?- error- even?- exact->inexact ; r5rs definition- expt- floor- for-each- gcd- import- ;include- ;include-ci- inexact->exact ; r5rs definition- input-port?- integer->char- integer?- lcm- length- let- let*- letrec- list- list->string- list->vector- list-ref- list-tail- list?- make-bytevector- make-string- make-vector- map- max- member- memq- memv- min- modulo- negative?- newline- not- null?- number->string- number?- numerator- odd?- or- output-port?- pair?- peek-char- positive?- procedure?- quasiquote- quotient- rational?- rationalize- read-char- real?- remainder- reverse- round- string- string->list- string->number- string->symbol- string->utf8- string-append- string-copy- string-length- string-ref- string<=?- string<?- string=?- string>=?- string>?- string?- substring- symbol->string- symbol?- truncate- utf8->string- values- vector- vector->list- vector-length- vector-ref- vector?- write-char- zero?-- ;=>- ;binary-port?- ;boolean=?- ;bytevector-u8-set!- ;call-with-port- ;close-port- ;cond-expand- ;current-error-port- ;define- ;define-record-type- ;define-syntax- ;define-values- ;else- ;eof-object- ;error-object-irritants- ;error-object-message- ;error-object?- ;exact- ;exact-integer-sqrt- ;exact-integer?- ;exact?- ;features- ;file-error?- ;floor-quotient- ;floor-remainder- ;floor/- ;flush-output-port- ;get-output-bytevector- ;get-output-string- ;guard- ;if- ;inexact- ;inexact?- ;input-port-open?- ;lambda- ;let*-values- ;let-syntax- ;let-values- ;letrec*- ;letrec-syntax- ;list-copy- ;list-set!- ;make-list- ;make-parameter- ;open-input-bytevector- ;open-input-string- ;open-output-bytevector- ;open-output-string- ;output-port-open?- ;parameterize- ;peek-u8- ;port?- ;quote- ;raise- ;raise-continuable- ;read-bytevector- ;read-bytevector!- ;read-error?- ;read-line- ;read-string- ;read-u8- ;set!- ;set-car!- ;set-cdr!- ;square- ;string->vector- ;string-copy!- ;string-fill!- ;string-for-each- ;string-map- ;string-set!- ;symbol=?- ;syntax-error- ;syntax-rules- ;textual-port?- ;truncate-quotient- ;truncate-remainder- ;truncate/- ;u8-ready?- ;unless- ;unquote- ;unquote-splicing- ;vector->string- ;vector-append- ;vector-copy- ;vector-copy!- ;vector-fill!- ;vector-for-each- ;vector-map- ;vector-set!- ;when- ;with-exception-handler- ;write-bytevector- ;write-string- ;write-u8- )- (import (scheme r5rs)))
− lib/scheme/r5rs/char.sld
@@ -1,38 +0,0 @@-;;;-;;; husk-scheme-;;; http://justinethier.github.com/husk-scheme-;;;-;;; Written by Justin Ethier-;;;-;;; r5rs equivalent libraries-;;;-;;; This library exposes an R5RS equivalent to -;;; the corresponding R7RS-small library.-;;;--(define-library (scheme r5rs char)- (export- char-alphabetic?- char-ci<=?- char-ci<?- char-ci=?- char-ci>=?- char-ci>?- ;char-downcase- ;char-foldcase- char-lower-case?- char-numeric?- ;char-upcase- char-upper-case?- char-whitespace?- ;digit-value- string-ci<=?- string-ci<?- string-ci=?- string-ci>=?- string-ci>?- ;string-downcase- ;string-foldcase- ;string-upcase- )- (import (scheme r5rs)))
− lib/scheme/r5rs/complex.sld
@@ -1,22 +0,0 @@-;;;-;;; husk-scheme-;;; http://justinethier.github.com/husk-scheme-;;;-;;; Written by Justin Ethier-;;;-;;; r5rs equivalent libraries-;;;-;;; This library exposes an R5RS equivalent to -;;; the corresponding R7RS-small library.-;;;--(define-library (scheme r5rs complex)- (export- angle- imag-part- magnitude- make-polar- make-rectangular- real-part- )- (import (scheme r5rs)))
− lib/scheme/r5rs/cxr.sld
@@ -1,40 +0,0 @@-;;;-;;; husk-scheme-;;; http://justinethier.github.com/husk-scheme-;;;-;;; Written by Justin Ethier-;;;-;;; r5rs equivalent libraries-;;;-;;; This library exposes an R5RS equivalent to -;;; the corresponding R7RS-small library.-;;;--(define-library (scheme r5rs cxr)- (export- caaaar- caaadr- caaar- caadar- caaddr- caadr- cadaar- cadadr- cadar- caddar- cadddr- caddr- cdaaar- cdaadr- cdaar- cdadar- cdaddr- cdadr- cddaar- cddadr- cddar- cdddar- cddddr- cdddr- )- (import (scheme r5rs)))
− lib/scheme/r5rs/eval.sld
@@ -1,20 +0,0 @@-;;;-;;; husk-scheme-;;; http://justinethier.github.com/husk-scheme-;;;-;;; Written by Justin Ethier-;;;-;;; r5rs equivalent libraries-;;;-;;; This library exposes an R5RS equivalent to -;;; the corresponding R7RS-small library.-;;;--(define-library (scheme r5rs eval)- (export - eval- current-environment- interaction-environment- make-environment- null-environment)- (import (scheme r5rs)))
− lib/scheme/r5rs/file.sld
@@ -1,26 +0,0 @@-;;;-;;; husk-scheme-;;; http://justinethier.github.com/husk-scheme-;;;-;;; Written by Justin Ethier-;;;-;;; r5rs equivalent libraries-;;;-;;; This library exposes an R5RS equivalent to -;;; the corresponding R7RS-small library.-;;;--(define-library (scheme r5rs file)- (export- call-with-input-file- call-with-output-file- delete-file- file-exists?- ;open-binary-input-file- ;open-binary-output-file- open-input-file- open-output-file- ;with-input-from-file- ;with-output-to-file- )- (import (scheme r5rs)))
− lib/scheme/r5rs/inexact.sld
@@ -1,28 +0,0 @@-;;;-;;; husk-scheme-;;; http://justinethier.github.com/husk-scheme-;;;-;;; Written by Justin Ethier-;;;-;;; r5rs equivalent libraries-;;;-;;; This library exposes an R5RS equivalent to -;;; the corresponding R7RS-small library.-;;;--(define-library (scheme r5rs inexact)- (export- acos- asin- atan- cos- exp- ;finite?- ;infinite?- log- ;nan?- sin- sqrt- tan- )- (import (scheme r5rs)))
− lib/scheme/r5rs/lazy.sld
@@ -1,21 +0,0 @@-;;;-;;; husk-scheme-;;; http://justinethier.github.com/husk-scheme-;;;-;;; Written by Justin Ethier-;;;-;;; r5rs equivalent libraries-;;;-;;; This library exposes an R5RS equivalent to -;;; the corresponding R7RS-small library.-;;;--(define-library (scheme r5rs lazy)- (export- ;delay- ;delay-force- force- make-promise- ;promise?- )- (import (scheme r5rs)))
− lib/scheme/r5rs/load.sld
@@ -1,15 +0,0 @@-;;;-;;; husk-scheme-;;; http://justinethier.github.com/husk-scheme-;;;-;;; Written by Justin Ethier-;;;-;;; r5rs equivalent libraries-;;;-;;; This library exposes an R5RS equivalent to -;;; the corresponding R7RS-small library.-;;;--(define-library (scheme r5rs load)- (export load)- (import (scheme r5rs)))
− lib/scheme/r5rs/read.sld
@@ -1,15 +0,0 @@-;;;-;;; husk-scheme-;;; http://justinethier.github.com/husk-scheme-;;;-;;; Written by Justin Ethier-;;;-;;; r5rs equivalent libraries-;;;-;;; This library exposes an R5RS equivalent to -;;; the corresponding R7RS-small library.-;;;--(define-library (scheme r5rs read)- (export read)- (import (scheme r5rs)))
− lib/scheme/r5rs/write.sld
@@ -1,20 +0,0 @@-;;;-;;; husk-scheme-;;; http://justinethier.github.com/husk-scheme-;;;-;;; Written by Justin Ethier-;;;-;;; r5rs equivalent libraries-;;;-;;; This library exposes an R5RS equivalent to -;;; the corresponding R7RS-small library.-;;;--(define-library (scheme r5rs write)- (export- display- write- ; write-shared- ; write-simple- )- (import (scheme r5rs)))
+ lib/scheme/read.sld view
@@ -0,0 +1,12 @@+;;;+;;; husk-scheme+;;; http://justinethier.github.com/husk-scheme+;;;+;;; Written by Justin Ethier+;;;+;;; r7rs read library+;;;++(define-library (scheme read)+ (export read)+ (import (scheme)))
+ lib/scheme/repl.sld view
@@ -0,0 +1,13 @@+;;;+;;; husk-scheme+;;; http://justinethier.github.com/husk-scheme+;;;+;;; Written by Justin Ethier+;;;+;;; r7rs-small repl library+;;;++(define-library (scheme repl)+ (export+ interaction-environment)+ (import (scheme)))
+ lib/scheme/write.sld view
@@ -0,0 +1,17 @@+;;;+;;; husk-scheme+;;; http://justinethier.github.com/husk-scheme+;;;+;;; Written by Justin Ethier+;;;+;;; r7rs write library+;;;++(define-library (scheme write)+ (export+ display+ write+ ; write-shared+ ; write-simple+ )+ (import (scheme)))
lib/stdlib.scm view
@@ -7,548 +7,6 @@ ;;; Standard library of scheme functions ;;; -(define call/cc call-with-current-continuation)--(define (caar pair) (car (car pair)))-(define (cadr pair) (car (cdr pair)))-(define (cdar pair) (cdr (car pair)))-(define (cddr pair) (cdr (cdr pair)))-(define (caaar pair) (car (car (car pair))))-(define (caadr pair) (car (car (cdr pair))))-(define (cadar pair) (car (cdr (car pair))))-(define (caddr pair) (car (cdr (cdr pair))))-(define (cdaar pair) (cdr (car (car pair))))-(define (cdadr pair) (cdr (car (cdr pair))))-(define (cddar pair) (cdr (cdr (car pair))))-(define (cdddr pair) (cdr (cdr (cdr pair))))-(define (caaaar pair) (car (car (car (car pair)))))-(define (caaadr pair) (car (car (car (cdr pair)))))-(define (caadar pair) (car (car (cdr (car pair)))))-(define (caaddr pair) (car (car (cdr (cdr pair)))))-(define (cadaar pair) (car (cdr (car (car pair)))))-(define (cadadr pair) (car (cdr (car (cdr pair)))))-(define (caddar pair) (car (cdr (cdr (car pair)))))-(define (cadddr pair) (car (cdr (cdr (cdr pair)))))-(define (cdaaar pair) (cdr (car (car (car pair)))))-(define (cdaadr pair) (cdr (car (car (cdr pair)))))-(define (cdadar pair) (cdr (car (cdr (car pair)))))-(define (cdaddr pair) (cdr (car (cdr (cdr pair)))))-(define (cddaar pair) (cdr (cdr (car (car pair)))))-(define (cddadr pair) (cdr (cdr (car (cdr pair)))))-(define (cdddar pair) (cdr (cdr (cdr (car pair)))))-(define (cddddr pair) (cdr (cdr (cdr (cdr pair)))))---(define (not x) (if x #f #t))--(define (list . objs) objs)-(define (id obj) obj)--; TODO: this is not flipping args. not part of R5RS, but -; as it is now, what is the point?-(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))))--(define (foldr func end lst)- (if (null? lst)- end- (func (car lst) (foldr func end (cdr lst)))))--(define (foldl func accum lst)- (if (null? lst)- accum- (foldl func (func (car lst) accum) (cdr lst))))--(define (sum . lst) (foldl + 0 lst))-(define (product . lst) (foldl * 1 lst))--; Forms from R5RS for and/or-(define-syntax and- (syntax-rules ()- ((and) #t)- ((and test) test)- ((and test1 test2 ...)- (if test1 (and test2 ...) #f))))--(define-syntax or- (syntax-rules ()- ((or) #f)- ((or test) test)- ((or test1 test2 ...)- (let ((x test1))- (if x x (or test2 ...))))))--(define (abs num)- (if (negative? num)- (* num -1)- num))--(define (max first . rest) (foldl (lambda (old new) (if (> old new) old new)) first rest))-(define (min first . rest) (foldl (lambda (old new) (if (< old new) old new)) first rest))--(define zero? (curry = 0))-(define positive? (curry < 0))-(define negative? (curry > 0))-(define (odd? num) (= (modulo num 2) 1))-(define (even? num) (= (modulo num 2) 0))--(define (length lst) (foldl (lambda (x y) (+ y 1)) 0 lst))-(define (reverse lst) (foldl (flip cons) '() lst))--(define-syntax begin- (syntax-rules ()- ((begin exp ...)- ((lambda () exp ...)))))--;-;-; NOTE: The below cond/case forms do NOT use begin to prevent-; conflicts between the stdlib begin and the begin form-; from the module metalanguage.-;-; TODO: this may indicate a problem with syntax-rules and-; referential transparency.-;-;--; cond-; Form from R5RS:-(define-syntax cond- (syntax-rules (else =>)- ((cond (else result1 result2 ...))-;-; TODO: see pitfall 3.2-;-; This is a modification from R5RS - we put the begin within-; an if statement, because in this context definitions are-; not allowed. This prevents one from interfering with macro-; hygiene. -;-; TODO: unfortunately the macro logic has not yet been-; updated to take this into acccount, so the pitfall-; still fails-;- ((lambda () result1 result2 ...))) ;; Intentionally not using begin, see above- ((cond (test => result))- (let ((temp test))- (if temp (result temp))))- ((cond (test => result) clause1 clause2 ...)- (let ((temp test))- (if temp- (result temp)- (cond clause1 clause2 ...))))- ((cond (test)) test)- ((cond (test) clause1 clause2 ...)- (let ((temp test))- (if temp- temp- (cond clause1 clause2 ...))))- ((cond (test result1 result2 ...))- (if test ((lambda () result1 result2 ...)))) ;; Intentionally not using begin, see above- ((cond (test result1 result2 ...)- clause1 clause2 ...)- (if test- ((lambda () result1 result2 ...)) ;; Intentionally not using begin, see above- (cond clause1 clause2 ...)))))-; Case-; Form from R5RS:-(define-syntax case- (syntax-rules (else)- ((case (key ...)- clauses ...)- (let ((atom-key (key ...)))- (case atom-key clauses ...)))- ((case key- (else result1 result2 ...))- (if #t ((lambda () result1 result2 ...)))) ;; Intentionally not using begin, see above- ((case key- ((atoms ...) result1 result2 ...))- (if (memv key '(atoms ...))- ((lambda () result1 result2 ...)))) ;; Intentionally not using begin, see above- ((case key- ((atoms ...) result1 result2 ...)- clause clauses ...)- (if (memv key '(atoms ...))- ((lambda () result1 result2 ...)) ;; Intentionally not using begin, see above- (case key clause clauses ...)))))--(define (my-mem-helper obj lst cmp-proc)- (cond - ((null? lst) #f)- ((cmp-proc obj (car lst)) lst)- (else (my-mem-helper obj (cdr lst) cmp-proc))))-(define (memq obj lst) (my-mem-helper obj lst eq?))-(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 (next acc) (if (and (not acc) (pred (op next))) next acc)))-(define (assq obj alist) (foldl (mem-helper (curry eq? obj) car) #f alist))-(define (assv obj alist) (foldl (mem-helper (curry eqv? obj) car) #f alist))-(define (assoc obj alist) (foldl (mem-helper (curry equal? obj) car) #f alist))--; SRFI 8-; Reference implementation from: http://srfi.schemers.org/srfi-8/srfi-8.html-;-; FUTURE: This may be moved into its own file-;-(define-syntax receive- (syntax-rules ()- ((receive formals expression body ...)- (call-with-values (lambda () expression)- (lambda formals body ...)))))-; END SRFI 8--; Added the following support functions from SRFI 1-(define (car+cdr pair) (values (car pair) (cdr pair)))-(define (%cars+cdrs lists)- (call-with-current-continuation- (lambda (abort)- (let recur ((lists lists))- (if (pair? lists)- (receive (list other-lists) (car+cdr lists)- (if (null? list) (abort '() '()) ; LIST is empty -- bail out- (receive (a d) (car+cdr list)- (receive (cars cdrs) (recur other-lists)- (values (cons a cars) (cons d cdrs))))))- (values '() '()))))))-; END support functions--(define (map f lis1 . lists)-; (check-arg procedure? f map-in-order)- (if (pair? lists)- (let recur ((lists (cons lis1 lists)))- (receive (cars cdrs) (%cars+cdrs lists)- (if (pair? cars)- (let ((x (apply f cars))) ; Do head first,- (cons x (recur cdrs))) ; then tail.- '())))- ;; Fast path.- (foldr (lambda (x y) (cons (f x) y)) '() lis1)))--(define (for-each f lis1 . lists)- (if (pair? lists)- (let recur ((lists (cons lis1 lists)))- (receive (cars cdrs) (%cars+cdrs lists)- (if (pair? cars)- (begin- (apply f cars)- (recur cdrs)))))- ;; Fast path.- (if (eq? 1 (length lis1))- (f (car lis1))- (begin (f (car lis1))- (for-each f (cdr lis1))))))--(define (list-tail lst k) - (if (zero? k)- lst- (list-tail (cdr lst) (- k 1))))-(define (list-ref lst k) (car (list-tail lst k)))--; Let forms-;-; letrec from R5RS-(define-syntax letrec- (syntax-rules ()- ((letrec ((var1 init1) ...) body ...)- (letrec "generate_temp_names"- (var1 ...)- ()- ((var1 init1) ...)- body ...))- ((letrec "generate_temp_names"- ()- (temp1 ...)- ((var1 init1) ...)- body ...) ; start the changed code- (let ((var1 #f) ...)- (let ((temp1 init1) ...)- (set! var1 temp1)- ...- body ...)))- ((letrec "generate_temp_names"- (x y ...)- (temp ...)- ((var1 init1) ...)- body ...)- (letrec "generate_temp_names"- (y ...)- (newtemp temp ...)- ((var1 init1) ...)- body ...))))--; let and named let (using the Y-combinator):-(define-syntax let- (syntax-rules ()- ((_ ((x v) ...) e1 e2 ...)- ((lambda (x ...) e1 e2 ...) v ...))- ((_ name ((x v) ...) e1 e2 ...)- (let*- ((f (lambda (name)- (lambda (x ...) e1 e2 ...)))- (ff ((lambda (proc) (f (lambda (x ...) ((proc proc)- x ...))))- (lambda (proc) (f (lambda (x ...) ((proc proc)- x ...)))))))- (ff v ...)))))--;-; It would be nice to change first rule back to:-; ((_ () body) body)-;-(define-syntax let*- (syntax-rules ()- ((let* () body1 body2 ...)- (let () body1 body2 ...))- ((let* ((name1 val1) (name2 val2) ...)- body1 body2 ...)- (let ((name1 val1))- (let* ((name2 val2) ...)- body1 body2 ...)))))--; Iteration - do-(define-syntax do- (syntax-rules ()- ((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- (lambda (object)- (object)))--(define-syntax delay - (syntax-rules () - ((delay expression)- (make-promise (lambda () expression)))))--(define make-promise- (lambda (proc)- (let ((result-ready? #f)- (result #f))- (lambda ()- (if result-ready? - result- (let ((x (proc)))- (if result-ready?- result- (begin (set! result x)- (set! result-ready? #t)- result))))))))--; End delayed evaluation section--; String Section-(define-syntax string-fill!- (syntax-rules ()- ((_ _str _chr)- (set! _str- (make-string (string-length _str) _chr)))))--(define (string-concatenate l) - (apply string-append l)) --; Vector Section-(define-syntax vector-fill!- (syntax-rules ()- ((_ _vec _fill)- (set! _vec- (make-vector (vector-length _vec) _fill)))))--; Bytevector Section--; TODO: add appropriate overloads, also note this is not the-; fastest implementation-(define (bytevector-copy! to at from start end)- (do ((i 0 (+ i 1)))- ((= i (- end start)))- (bytevector-u8-set! - to- (+ at i) - (bytevector-u8-ref from (+ start i)))))--; Continuation Section-(define (values . things)- (call-with-current-continuation - (lambda (cont) (apply cont things))))--;; I/O Section-(define (newline . port)- (if (null? port) - (display #\newline) - (display #\newline port)))--; TODO: test these forms-(define (call-with-input-file filename proc)- (let ((opened-file (open-input-file filename)))- (define result- (proc opened-file))- (close-input-port opened-file)- result))-; TODO: test-(define (call-with-output-file filename proc)- (let ((opened-file (open-output-file filename)))- (define result- (proc opened-file))- (close-output-port opened-file)- result))--;; SRFI 23 - Error reporting mechanism-;; based on code from: http://srfi.schemers.org/srfi-23/srfi-23.html-(define (error reason . args)- (display "Error: ")- (display reason)- (newline)- (for-each (lambda (arg) - (display " ")- (write arg))- args)- (newline)- (exit-fail))--;; Hashtable derived forms-(define hash-table-walk- (lambda (ht proc)- (map - (lambda (kv) (proc (car kv) (car (reverse kv))))- (hash-table->alist ht)))) --(define (hash-table-update! hash-table key function)- (hash-table-set! hash-table key- (function (hash-table-ref hash-table key))))--(define-syntax hash-table-merge!- (syntax-rules ()- ((_ hdest hsrc)- (map (lambda (node) (hash-table-set! hdest - (car node)- (cadr node)))- (hash-table->alist hsrc)))))--(define (alist->hash-table lst)- (let ((ht (make-hash-table)))- (for-each (lambda (node)- (hash-table-set! ht (car node) (cadr node)))- lst)- ht))--(define (hash-table-fold hash-table f acc-in)- (let ((acc acc-in))- (hash-table-walk hash-table - (lambda (key value) (set! acc (f key value acc))))- acc))--; Implementations of gcd and lcm using Euclid's algorithm-;-; Also note that each form is written to accept either 0 or-; 2 arguments, per R5RS. This could probably be generalized-; even further, if necessary.-;-(define gcd '())-(define lcm '())--(let ()- ; Main GCD algorithm- (define (gcd/main a b)- (if (= b 0)- (abs a)- (gcd/main b (modulo a b))))-- ; A helper function to reduce the input list- (define (gcd/entry . nums)- (if (eqv? nums '())- 0- (foldl gcd/main (car nums) (cdr nums))))-- ; Main LCM algorithm- (define (lcm/main a b)- (abs (/ (* a b) (gcd/main a b))))-- ; A helper function to reduce the input list- (define (lcm/entry . nums)- (if (eqv? nums '())- 1- (foldl lcm/main (car nums) (cdr nums))))-- (set! gcd gcd/entry)- (set! lcm lcm/entry)) --; append accepts a variable number of arguments, per R5RS. So a wrapper-; has been provided for the standard 2-argument version of (append).-;-; We return the given value if less than 2 arguments are given, and-; otherwise fold over each arg, appending it to its predecessor. -(define (append . lst)- (define append-2- (lambda (inlist alist) - (foldr (lambda (ap in) (cons ap in)) alist inlist)))- (if (null? lst)- lst- (if (null? (cdr lst))- (car lst)- (foldl (lambda (a b) (append-2 b a)) (car lst) (cdr lst)))))--; Quasi-quotation as a macro-; Based on code from chibi-scheme-;-; The code below is compiled to avoid having to expand dozens of macros-; in real-time, significantly improving performance. This does highlight-; an area that husk could improve upon but for now a compilation will do.-;-; The (expand) special form is used to compile the code, in case it needs-; to be changed in the future.-;-(define-syntax quasiquote- (er-macro-transformer- (lambda (expr rename compare)-(define (qq x d) (if (pair? x) ((lambda () (if (compare (rename (quote unquote)) (car x)) ((lambda () (if (<= d 0) (cadr x) (list (rename (quote list)) (list (rename (quote quote)) (quote unquote)) (qq (cadr x) (- d 1)))))) (if (compare (rename (quote unquote-splicing)) (car x)) ((lambda () (if (<= d 0) (list (rename (quote cons)) (qq (car x) d) (qq (cdr x) d)) (list (rename (quote list)) (list (rename (quote quote)) (quote unquote-splicing)) (qq (cadr x) (- d 1)))))) (if (compare (rename (quote quasiquote)) (car x)) ((lambda () (list (rename (quote list)) (list (rename (quote quote)) (quote quasiquote)) (qq (cadr x) (+ d 1))))) (if (if (<= d 0) (if (pair? (car x)) (compare (rename (quote unquote-splicing)) (caar x)) #f) #f) ((lambda () (if (null? (cdr x)) (cadr (car x)) (list (rename (quote append)) (cadr (car x)) (qq (cdr x) d))))) (if #t ((lambda () (list (rename (quote cons)) (qq (car x) d) (qq (cdr x) d))))))))))) (if (vector? x) ((lambda () (list (rename (quote list->vector)) (qq (vector->list x) d)))) (if (if (symbol? x) #t (null? x)) ((lambda () (list (rename (quote quote)) x))) (if #t ((lambda () x)))))))- (qq (cadr expr) 0))))-;; Original code:-; (define (qq x d)-; (cond-; ((pair? x)-; (cond-; ((compare (rename 'unquote) (car x))-; (if (<= d 0)-; (cadr x)-; (list (rename 'list) (list (rename 'quote) 'unquote)-; (qq (cadr x) (- d 1)))))-; ((compare (rename 'unquote-splicing) (car x))-; (if (<= d 0)-; (list (rename 'cons) (qq (car x) d) (qq (cdr x) d))-; (list (rename 'list) (list (rename 'quote) 'unquote-splicing)-; (qq (cadr x) (- d 1)))))-; ((compare (rename 'quasiquote) (car x))-; (list (rename 'list) (list (rename 'quote) 'quasiquote)-; (qq (cadr x) (+ d 1))))-; ((and (<= d 0) (pair? (car x))-; (compare (rename 'unquote-splicing) (caar x)))-; (if (null? (cdr x))-; (cadr (car x))-; (list (rename 'append) (cadr (car x)) (qq (cdr x) d))))-; (else-; (list (rename 'cons) (qq (car x) d) (qq (cdr x) d)))))-; ((vector? x) (list (rename 'list->vector) (qq (vector->list x) d)))-; ((if (symbol? x) #t (null? x)) (list (rename 'quote) x))-; (else x)))-; (qq (cadr expr) 0))))+(load "cxr.scm")+(load "core.scm")+(load "lazy.scm")