diff --git a/ChangeLog.markdown b/ChangeLog.markdown --- a/ChangeLog.markdown +++ b/ChangeLog.markdown @@ -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 R7RS mode. +- Added most of the standard R7RS libraries: `(scheme base)`, `(scheme char)`, etc. +- Extended syntax-rules to allow another identifier to be used to specify the ellipsis symbol, per R7RS. For example, `:::` could be used instead: + + (define-syntax and + (syntax-rules ::: () + ((and test1 test2 :::) + (if test1 (and test2 :::) #f)))) + +- Added the following functions from R7RS: `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 -------- diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -33,7 +33,6 @@ (lambda () ...) huski> (hello) world - huski> husk has been tested on Windows, Linux, and FreeBSD. diff --git a/hs-src/Compiler/huskc.hs b/hs-src/Compiler/huskc.hs --- a/hs-src/Compiler/huskc.hs +++ b/hs-src/Compiler/huskc.hs @@ -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 diff --git a/hs-src/Interpreter/shell.hs b/hs-src/Interpreter/shell.hs --- a/hs-src/Interpreter/shell.hs +++ b/hs-src/Interpreter/shell.hs @@ -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 diff --git a/hs-src/Language/Scheme/Compiler.hs b/hs-src/Language/Scheme/Compiler.hs --- a/hs-src/Language/Scheme/Compiler.hs +++ b/hs-src/Language/Scheme/Compiler.hs @@ -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]) diff --git a/hs-src/Language/Scheme/Compiler/Libraries.hs b/hs-src/Language/Scheme/Compiler/Libraries.hs --- a/hs-src/Language/Scheme/Compiler/Libraries.hs +++ b/hs-src/Language/Scheme/Compiler/Libraries.hs @@ -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 diff --git a/hs-src/Language/Scheme/Compiler/Types.hs b/hs-src/Language/Scheme/Compiler/Types.hs --- a/hs-src/Language/Scheme/Compiler/Types.hs +++ b/hs-src/Language/Scheme/Compiler/Types.hs @@ -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 ++ " " diff --git a/hs-src/Language/Scheme/Core.hs b/hs-src/Language/Scheme/Core.hs --- a/hs-src/Language/Scheme/Core.hs +++ b/hs-src/Language/Scheme/Core.hs @@ -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-ci=?", stringCIEquals), - ("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-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 - diff --git a/hs-src/Language/Scheme/Environments.hs b/hs-src/Language/Scheme/Environments.hs new file mode 100644 --- /dev/null +++ b/hs-src/Language/Scheme/Environments.hs @@ -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-ci=?", stringCIEquals), + ("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-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 + diff --git a/hs-src/Language/Scheme/Libraries.hs b/hs-src/Language/Scheme/Libraries.hs --- a/hs-src/Language/Scheme/Libraries.hs +++ b/hs-src/Language/Scheme/Libraries.hs @@ -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 diff --git a/hs-src/Language/Scheme/Macro.hs b/hs-src/Language/Scheme/Macro.hs --- a/hs-src/Language/Scheme/Macro.hs +++ b/hs-src/Language/Scheme/Macro.hs @@ -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 _ diff --git a/hs-src/Language/Scheme/Primitives.hs b/hs-src/Language/Scheme/Primitives.hs --- a/hs-src/Language/Scheme/Primitives.hs +++ b/hs-src/Language/Scheme/Primitives.hs @@ -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 diff --git a/hs-src/Language/Scheme/Types.hs b/hs-src/Language/Scheme/Types.hs --- a/hs-src/Language/Scheme/Types.hs +++ b/hs-src/Language/Scheme/Types.hs @@ -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 _) = "" showVal (Continuation _ _ _ _ _) = "" -showVal (Syntax _ _ _ _ _) = "" +showVal (Syntax _ _ _ _ _ _) = "" showVal (SyntaxExplicitRenaming _) = "" 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 diff --git a/hs-src/Language/Scheme/Variables.hs b/hs-src/Language/Scheme/Variables.hs --- a/hs-src/Language/Scheme/Variables.hs +++ b/hs-src/Language/Scheme/Variables.hs @@ -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. diff --git a/husk-scheme.cabal b/husk-scheme.cabal --- a/husk-scheme.cabal +++ b/husk-scheme.cabal @@ -1,5 +1,5 @@ Name: husk-scheme -Version: 3.12 +Version: 3.13 Synopsis: R5RS Scheme interpreter, compiler, and library. Description: <> @@ -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 diff --git a/lib/core.scm b/lib/core.scm new file mode 100644 --- /dev/null +++ b/lib/core.scm @@ -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 + diff --git a/lib/cxr.scm b/lib/cxr.scm new file mode 100644 --- /dev/null +++ b/lib/cxr.scm @@ -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))))) + diff --git a/lib/lazy.scm b/lib/lazy.scm new file mode 100644 --- /dev/null +++ b/lib/lazy.scm @@ -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)))))))) diff --git a/lib/modules.scm b/lib/modules.scm --- a/lib/modules.scm +++ b/lib/modules.scm @@ -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) diff --git a/lib/scheme/base.sld b/lib/scheme/base.sld --- a/lib/scheme/base.sld +++ b/lib/scheme/base.sld @@ -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? + 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? + 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))) diff --git a/lib/scheme/case-lambda.sld b/lib/scheme/case-lambda.sld new file mode 100644 --- /dev/null +++ b/lib/scheme/case-lambda.sld @@ -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 ...) ...))))))) + )) diff --git a/lib/scheme/char.sld b/lib/scheme/char.sld new file mode 100644 --- /dev/null +++ b/lib/scheme/char.sld @@ -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-downcase + ;char-foldcase + char-lower-case? + char-numeric? + ;char-upcase + char-upper-case? + char-whitespace? + ;digit-value + string-ci<=? + string-ci=? + string-ci>? + ;string-downcase + ;string-foldcase + ;string-upcase + ) + (import (scheme))) diff --git a/lib/scheme/complex.sld b/lib/scheme/complex.sld new file mode 100644 --- /dev/null +++ b/lib/scheme/complex.sld @@ -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))) diff --git a/lib/scheme/cxr.sld b/lib/scheme/cxr.sld new file mode 100644 --- /dev/null +++ b/lib/scheme/cxr.sld @@ -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))) diff --git a/lib/scheme/eval.sld b/lib/scheme/eval.sld new file mode 100644 --- /dev/null +++ b/lib/scheme/eval.sld @@ -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))) diff --git a/lib/scheme/file.sld b/lib/scheme/file.sld new file mode 100644 --- /dev/null +++ b/lib/scheme/file.sld @@ -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))) diff --git a/lib/scheme/inexact.sld b/lib/scheme/inexact.sld new file mode 100644 --- /dev/null +++ b/lib/scheme/inexact.sld @@ -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))) diff --git a/lib/scheme/lazy.sld b/lib/scheme/lazy.sld new file mode 100644 --- /dev/null +++ b/lib/scheme/lazy.sld @@ -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))) diff --git a/lib/scheme/load.sld b/lib/scheme/load.sld new file mode 100644 --- /dev/null +++ b/lib/scheme/load.sld @@ -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))) diff --git a/lib/scheme/process-context.sld b/lib/scheme/process-context.sld new file mode 100644 --- /dev/null +++ b/lib/scheme/process-context.sld @@ -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))) diff --git a/lib/scheme/r5rs.sld b/lib/scheme/r5rs.sld new file mode 100644 --- /dev/null +++ b/lib/scheme/r5rs.sld @@ -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))) diff --git a/lib/scheme/r5rs/base.sld b/lib/scheme/r5rs/base.sld deleted file mode 100644 --- a/lib/scheme/r5rs/base.sld +++ /dev/null @@ -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? - 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? - 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))) diff --git a/lib/scheme/r5rs/char.sld b/lib/scheme/r5rs/char.sld deleted file mode 100644 --- a/lib/scheme/r5rs/char.sld +++ /dev/null @@ -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-downcase - ;char-foldcase - char-lower-case? - char-numeric? - ;char-upcase - char-upper-case? - char-whitespace? - ;digit-value - string-ci<=? - string-ci=? - string-ci>? - ;string-downcase - ;string-foldcase - ;string-upcase - ) - (import (scheme r5rs))) diff --git a/lib/scheme/r5rs/complex.sld b/lib/scheme/r5rs/complex.sld deleted file mode 100644 --- a/lib/scheme/r5rs/complex.sld +++ /dev/null @@ -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))) diff --git a/lib/scheme/r5rs/cxr.sld b/lib/scheme/r5rs/cxr.sld deleted file mode 100644 --- a/lib/scheme/r5rs/cxr.sld +++ /dev/null @@ -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))) diff --git a/lib/scheme/r5rs/eval.sld b/lib/scheme/r5rs/eval.sld deleted file mode 100644 --- a/lib/scheme/r5rs/eval.sld +++ /dev/null @@ -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))) diff --git a/lib/scheme/r5rs/file.sld b/lib/scheme/r5rs/file.sld deleted file mode 100644 --- a/lib/scheme/r5rs/file.sld +++ /dev/null @@ -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))) diff --git a/lib/scheme/r5rs/inexact.sld b/lib/scheme/r5rs/inexact.sld deleted file mode 100644 --- a/lib/scheme/r5rs/inexact.sld +++ /dev/null @@ -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))) diff --git a/lib/scheme/r5rs/lazy.sld b/lib/scheme/r5rs/lazy.sld deleted file mode 100644 --- a/lib/scheme/r5rs/lazy.sld +++ /dev/null @@ -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))) diff --git a/lib/scheme/r5rs/load.sld b/lib/scheme/r5rs/load.sld deleted file mode 100644 --- a/lib/scheme/r5rs/load.sld +++ /dev/null @@ -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))) diff --git a/lib/scheme/r5rs/read.sld b/lib/scheme/r5rs/read.sld deleted file mode 100644 --- a/lib/scheme/r5rs/read.sld +++ /dev/null @@ -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))) diff --git a/lib/scheme/r5rs/write.sld b/lib/scheme/r5rs/write.sld deleted file mode 100644 --- a/lib/scheme/r5rs/write.sld +++ /dev/null @@ -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))) diff --git a/lib/scheme/read.sld b/lib/scheme/read.sld new file mode 100644 --- /dev/null +++ b/lib/scheme/read.sld @@ -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))) diff --git a/lib/scheme/repl.sld b/lib/scheme/repl.sld new file mode 100644 --- /dev/null +++ b/lib/scheme/repl.sld @@ -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))) diff --git a/lib/scheme/write.sld b/lib/scheme/write.sld new file mode 100644 --- /dev/null +++ b/lib/scheme/write.sld @@ -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))) diff --git a/lib/stdlib.scm b/lib/stdlib.scm --- a/lib/stdlib.scm +++ b/lib/stdlib.scm @@ -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")