husk-scheme 3.5.2.3 → 3.5.3
raw patch · 7 files changed
+371/−174 lines, 7 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Language.Scheme.Compiler: compileSpecialForm :: String -> String -> CompOpts -> IOThrowsError HaskAST
+ Language.Scheme.Compiler: compileSpecialFormEntryPoint :: String -> String -> CompOpts -> IOThrowsError HaskAST
+ Language.Scheme.Core: substr :: (LispVal, LispVal, LispVal) -> IOThrowsError LispVal
+ Language.Scheme.Core: updateVector :: LispVal -> LispVal -> LispVal -> IOThrowsError LispVal
Files
- README.markdown +1/−89
- hs-src/Compiler/huskc.hs +28/−11
- hs-src/Language/Scheme/Compiler.hs +242/−25
- hs-src/Language/Scheme/Core.hs +59/−35
- hs-src/Language/Scheme/FFI.hs +27/−13
- husk-scheme.cabal +1/−1
- stdlib.scm +13/−0
README.markdown view
@@ -6,100 +6,12 @@ Scheme is one of two main dialects of Lisp. Scheme follows a minimalist design philosophy: the core language consists of a small number of fundamental forms which may be used to implement other built-in forms. Scheme is an excellent language for writing small, elegant programs, and may also be used to write scripts or embed scripting functionality within a larger application. -Feature List--------------husk includes most features from R<sup>5</sup>RS, including:--- Primitive data types and their standard forms, including string, char, numbers (integer, rational, floating point, and complex), list, pair, vector, and symbols-- Proper tail recursion-- Proper lexical scoping-- Conditionals: if, case, cond-- Sequencing: begin-- Iteration: do-- Quasi-quotation-- Delayed Execution: delay, force-- Binding constructs: let, named let, let*, letrec-- Assignment operations-- Basic IO functions-- Standard library of Scheme functions-- Read-Eval-Print-Loop (REPL) interpreter, with input driven by Haskeline to provide a rich user experience-- Full numeric tower: includes support for parsing/storing types (exact, inexact, etc), support for operations on these types as well as mixing types and other constraints from the R<sup>5</sup>RS specification.-- Continuations: First-class continuations of unlimited extent, call/cc, and call-with-values.-- Hygienic Macros: High-level macros via define-syntax, let-syntax, and letrec-syntax - *Note this is still somewhat of a work in progress* - Macro support has improve significantly in the last few releases, and it works well enough that almost all derived forms are implemented as macros in our standard library, but you may still run into problems when defining your own macros.--As well as the following approved extensions:--- Hash tables, as specified by [SRFI 69](http://srfi.schemers.org/srfi-69/srfi-69.html)--And the following R<sup>7</sup>RS draft features:--- Nested block comments using `#|` and `|#`- Installation ------------ husk may be installed using [cabal](http://www.haskell.org/cabal/) - just run the following command: cabal install husk-scheme -Usage--------The interpreter may be invoked by running it directly from the command line:-- ./huski--Alternatively, you may run an individual scheme program:-- ./huski my-scheme-file.scm--API------A Haskell API is also provided to allow you to embed a Scheme interpreter within a Haskell program. The key API modules are:--- `Language.Scheme.Core` - Contains functions to evaluate (execute) Scheme code.-- `Language.Scheme.Types` - Contains Haskell data types used to represent Scheme primitives.--For more information, run `make doc` to generate API documentation from the source code. Also, see `shell.hs` for a quick example of how you might get started.--Foreign Function Interface-----------------------------A foreign function interface (FFI) is provided to allow husk to call into arbitrary Haskell code. The interface is currently available via the `load-ffi` function:-- (load-ffi "Language.Scheme.Plugins.CPUTime" "precision" "cpu-time:precision")--`load-ffi` accepts the following string arguments:--- Name of a Haskell module to dynamically load-- Haskell function to load from that module-- Name to use for the function after it is loaded into husk--From the previous example, once `cpu-time:precision` is loaded, it may be called directly from husk just like a regular Scheme function:-- (cpu-time:precision)--Any Haskell function loaded via the FFI must be of the following type:-- [LispVal] -> IOThrowsError LispVal--See husk's `Language.Scheme.Plugins.CPUTime` module for an example of how to use the husk FFI.--Development--------------The following packages are required to build husk scheme:--- [GHC](http://www.haskell.org/ghc/)-- [cabal-install](http://hackage.haskell.org/trac/hackage/wiki/CabalInstall) may be used to build, deploy, and generate packages for husk.-- [Haskeline](http://trac.haskell.org/haskeline) - which may be installed using cabal: `cabal install haskeline`--The `tests` directory contains unit tests for much of the scheme code. All tests may be executed via the `make test` command.--The `examples` directory contains example scheme programs.--Patches are welcome! Please send them via a pull request on github. Also, when making code changes please try to add at least one test case for your change, and ensure that the change does not break any existing unit tests.- License ------- @@ -112,5 +24,5 @@ The interpreter is based on code from the book [Write Yourself a Scheme in 48 Hours](http://en.wikibooks.org/wiki/Write_Yourself_a_Scheme_in_48_Hours) written by Jonathan Tang and hosted / maintained by Wikibooks. -If you would like to request changes, report bug fixes, or contact me, visit the project web site at [GitHub](http://github.com/justinethier/husk-scheme).+For more information, please visit the [project web site](http://justinethier.github.com/husk-scheme).
hs-src/Compiler/huskc.hs view
@@ -38,7 +38,7 @@ args <- getArgs let (actions, nonOpts, msgs) = getOpt Permute options args opts <- foldl (>>=) (return defaultOptions) actions- let Options {optOutput = output} = opts+ let Options {optOutput = output, optDynamic = dynamic, optCustomOptions = extra} = opts if null nonOpts then showUsage@@ -47,7 +47,10 @@ outExec = case output of Just inFile -> inFile Nothing -> dropExtension inFile- process inFile outExec+ extraOpts = case extra of+ Just args -> args+ Nothing -> ""+ process inFile outExec dynamic extraOpts -- -- For an explanation of the command line options code, see:@@ -56,13 +59,17 @@ -- |Data type to handle command line options that take parameters data Options = Options {- optOutput :: Maybe String -- Executable file to write+ optOutput :: Maybe String, -- Executable file to write+ optDynamic :: Bool, -- Flag for dynamic linking of compiled executable+ optCustomOptions :: Maybe String -- Custom options to ghc } -- |Default values for the command line options defaultOptions :: Options defaultOptions = Options {- optOutput = Nothing + optOutput = Nothing,+ optDynamic = False,+ optCustomOptions = Nothing } -- |Command line options@@ -70,13 +77,19 @@ options = [ 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"+ Option ['o'] ["output"] (ReqArg writeExec "FILE") "output file to write",+ Option ['d'] ["dynamic"] (NoArg getDynamic) "use dynamic linking for the compiled executable",+ Option ['x'] ["extra"] (ReqArg getExtraArgs "Args") "extra arguments to ghc" ] -- |Determine executable file to write. -- This version just takes a name from the command line option writeExec arg opt = return opt { optOutput = Just arg } +getDynamic opt = return opt { optDynamic = True }++getExtraArgs arg opt = return opt { optCustomOptions = Just arg }+ -- TODO: would nice to have this as well as a 'real' usage printout, perhaps via --help -- |Print a usage message@@ -92,6 +105,9 @@ putStrLn " --help Display this information" putStrLn " --version Display husk version information" putStrLn " --output filename Write executable to the given filename"+ putStrLn " --dynamic Use dynamic Haskell libraries, if available"+ putStrLn " (Requires libraries built via --enable-shared)"+ putStrLn " --extra args Pass extra arguments directly to ghc" putStrLn "" exitWith ExitSuccess @@ -103,13 +119,13 @@ exitWith ExitSuccess -- |High level code to compile the given file-process :: String -> String -> IO ()-process inFile outExec = do+process :: String -> String -> Bool -> String -> IO ()+process inFile outExec dynamic extraArgs = do env <- liftIO $ nullEnv stdlib <- getDataFileName "stdlib.scm" result <- (runIOThrows $ liftM show $ compileSchemeFile env stdlib inFile) case result of- "" -> compileHaskellFile outExec+ "" -> compileHaskellFile outExec dynamic extraArgs _ -> putStrLn result -- |Compile a scheme file to haskell@@ -129,10 +145,11 @@ else throwError $ Default "Empty file" --putStrLn "empty file" -- |Compile the intermediate haskell file using GHC-compileHaskellFile :: String -> IO() --ThrowsError LispVal-compileHaskellFile filename = do+compileHaskellFile :: String -> Bool -> String -> IO() --ThrowsError LispVal+compileHaskellFile filename dynamic extraArgs = do let ghc = "ghc" -- Need to make configurable??- compileStatus <- system $ ghc ++ " -cpp --make -package ghc -fglasgow-exts -o " ++ filename ++ " _tmp.hs"+ dynamicArg = if dynamic then "-dynamic" else ""+ compileStatus <- system $ ghc ++ " " ++ dynamicArg ++ " " ++ extraArgs ++ " -cpp --make -package ghc -fglasgow-exts -o " ++ filename ++ " _tmp.hs" -- TODO: delete intermediate hs files if requested
hs-src/Language/Scheme/Compiler.hs view
@@ -1,8 +1,5 @@---- TODO items: lambda params, define, a simple test suite- {- |-Module : Language.Scheme.Core+Module : Language.Scheme.Compiler Copyright : Justin Ethier Licence : MIT (see LICENSE in the distribution) @@ -14,6 +11,13 @@ The compiler performs the following transformations: Scheme AST (LispVal) -> Haskell AST (HaskAST) -> Compiled Code (String)++The GHC compiler is then used to create a native executable.++At present, the focus has just been on creating a compiler that will+generate correct, working code. Many optimizations could and need to+be made for time and space...+ -} module Language.Scheme.Compiler where @@ -107,7 +111,6 @@ header :: [String] header = [ "module Main where "--- Currently not used: , "import Language.Scheme.Compiler.Helpers " , "import Language.Scheme.Core " , "import Language.Scheme.Numerical " , "import Language.Scheme.Primitives "@@ -199,10 +202,34 @@ compile _ (List [Atom "quote", val]) copts = compileScalar (" return $ " ++ astToHaskellStr val) copts + -- TODO: eval envi cont (List [Atom "quasiquote", value]) = cpsUnquote envi cont value Nothing--- TODO: eval env cont (List (Atom "let-syntax" : List _bindings : _body)) = do--- TODO: eval env cont (List (Atom "letrec-syntax" : List _bindings : _body)) = do+-- +-- This is only a temporary solution that does not handle unquoting+--+compile _ (List [Atom "quasiquote", val]) copts = compileScalar (" return $ " ++ astToHaskellStr val) copts ++compile env args@(List (Atom "let-syntax" : List _bindings : _body)) copts = do+ -- TODO: check if let-syntax has been rebound?+ bodyEnv <- liftIO $ extendEnv env []+ _ <- Language.Scheme.Macro.loadMacros env bodyEnv Nothing False _bindings+ -- Expand whole body as a single continuous macro, to ensure hygiene+ expanded <- Language.Scheme.Macro.expand bodyEnv False $ List _body + case expanded of+ List e -> compile bodyEnv (List $ Atom "begin" : e) copts+ e -> compile bodyEnv e copts++compile env args@(List (Atom "letrec-syntax" : List _bindings : _body)) copts = do+ -- TODO: check if let-syntax has been rebound?+ bodyEnv <- liftIO $ extendEnv env []+ _ <- Language.Scheme.Macro.loadMacros bodyEnv bodyEnv Nothing False _bindings+ -- Expand whole body as a single continuous macro, to ensure hygiene+ expanded <- Language.Scheme.Macro.expand bodyEnv False $ List _body + case expanded of+ List e -> compile bodyEnv (List $ Atom "begin" : e) copts+ e -> compile bodyEnv e copts+ compile env args@(List [Atom "define-syntax", Atom keyword, (List (Atom "syntax-rules" : (List identifiers : rules)))]) copts = do -- -- TODO:@@ -219,7 +246,7 @@ compile env (List [Atom "if", predic, conseq, Nil ""]) copts compile env args@(List [Atom "if", predic, conseq, alt]) copts@(CompileOptions thisFunc _ _ nextFunc) = do- -- TODO: think about it, these could probably be part of compileExpr+ -- FUTURE: think about it, these could probably be part of compileExpr Atom symPredicate <- _gensym "ifPredic" Atom symCheckPredicate <- _gensym "compiledIfPredicate" Atom symConsequence <- _gensym "compiledConsequence"@@ -246,27 +273,32 @@ Atom symDefine <- _gensym "setFunc" Atom symMakeDefine <- _gensym "setFuncMakeSet" --- TODO: need to store var in huskc's env for macro processing+ -- Store var in huskc's env for macro processing+ -- TODO: changed this to a 'defineVar' for now, because without lambda forms inserting+ -- defined variables, using setVar will cause an error when trying to set a+ -- lambda var...+ _ <- defineVar env var form -- TODO: setVar (per above comment) - -- Entry point; ensure var is not rebound- f <- return $ [AstValue $ " bound <- liftIO $ isRecBound env \"set!\"",- AstValue $ " if bound ",- AstValue $ " then throwError $ NotImplemented \"prepareApply env cont args\" ", -- if is bound to a variable in this scope; call into it- AstValue $ " else do " ++ symDefine ++ " env cont (Nil \"\") []" ]+ entryPt <- compileSpecialFormEntryPoint "set!" symDefine copts compDefine <- compileExpr env form symDefine $ Just symMakeDefine compMakeDefine <- return $ AstFunction symMakeDefine " env cont result _ " [ AstValue $ " _ <- setVar env \"" ++ var ++ "\" result", createAstCont copts "result" ""]- return $ [createAstFunc copts f] ++ compDefine ++ [compMakeDefine]+ return $ [entryPt] ++ compDefine ++ [compMakeDefine] --- TODO: eval env cont args@(List [Atom "set!", nonvar, _]) = do --- TODO: eval env cont fargs@(List (Atom "set!" : args)) = do+compile env (List [Atom "set!", nonvar, _]) copts = do + f <- compileSpecialForm "set!" ("throwError $ TypeMismatch \"variable\" $ String \"" ++ (show nonvar) ++ "\"") copts+ return [f]+compile env (List (Atom "set!" : args)) copts = do+ f <- compileSpecialForm "set!" ("throwError $ NumArgs 2 $ [String \"" ++ (show args) ++ "\"]") copts -- TODO: Cheesy to use a string, but fine for now...+ return [f] compile env args@(List [Atom "define", Atom var, form]) copts@(CompileOptions thisFunc _ _ nextFunc) = do Atom symDefine <- _gensym "defineFuncDefine" Atom symMakeDefine <- _gensym "defineFuncMakeDef" --- TODO: need to store var in huskc's env for macro processing (and same for other vers of define)+ -- Store var in huskc's env for macro processing (and same for other vers of define)+ _ <- defineVar env var form -- Entry point; ensure var is not rebound f <- return $ [AstValue $ " bound <- liftIO $ isRecBound env \"define\"",@@ -284,6 +316,10 @@ compiledParams <- compileLambdaList fparams compiledBody <- compileBlock symCallfunc Nothing env [] fbody +-- TODO:+-- -- Store var in huskc's env for macro processing (and same for other vers of define)+-- _ <- defineVar e var form+ -- Entry point; ensure var is not rebound f <- return $ [AstValue $ " bound <- liftIO $ isRecBound env \"define\"", AstValue $ " if bound ",@@ -299,6 +335,10 @@ compiledParams <- compileLambdaList fparams compiledBody <- compileBlock symCallfunc Nothing env [] fbody +-- TODO:+-- -- Store var in huskc's env for macro processing (and same for other vers of define)+-- _ <- defineVar e var form+ -- Entry point; ensure var is not rebound f <- return $ [AstValue $ " bound <- liftIO $ isRecBound env \"define\"", AstValue $ " if bound ",@@ -316,7 +356,7 @@ compiledParams <- compileLambdaList fparams -- TODO: need to extend Env below when compiling body?--- TODO: need to bind lambda params in the extended env, for purposes of macro processing?+-- TODO: need to bind lambda params in the extended env, for purposes of macro processing compiledBody <- compileBlock symCallfunc Nothing env [] fbody @@ -331,22 +371,183 @@ ] return $ [createAstFunc copts f] ++ compiledBody +compile env args@(List (Atom "lambda" : DottedList fparams varargs : fbody)) copts@(CompileOptions thisFunc _ _ nextFunc) = do+ Atom symCallfunc <- _gensym "lambdaFuncEntryPt"+ compiledParams <- compileLambdaList fparams +-- TODO: need to extend Env below when compiling body?+-- TODO: need to bind lambda params in the extended env, for purposes of macro processing --- TODO: eval env cont args@(List (Atom "lambda" : DottedList fparams varargs : fbody)) = do--- TODO: eval env cont args@(List (Atom "lambda" : varargs@(Atom _) : fbody)) = do--- TODO: eval env cont args@(List [Atom "string-set!", Atom var, i, character]) = do+ compiledBody <- compileBlock symCallfunc Nothing env [] fbody++ -- Entry point; ensure var is not rebound+ f <- return $ [AstValue $ " bound <- liftIO $ isRecBound env \"lambda\"",+ AstValue $ " if bound ",+ AstValue $ " then throwError $ NotImplemented \"prepareApply env cont args\" ", -- if is bound to a variable in this scope; call into it+ AstValue $ " else do result <- makeHVarargs (" ++ astToHaskellStr varargs ++ ") env (" ++ compiledParams ++ ") " ++ symCallfunc,+ createAstCont copts "result" " "+ ]+ return $ [createAstFunc copts f] ++ compiledBody++compile env args@(List (Atom "lambda" : varargs@(Atom _) : fbody)) copts@(CompileOptions thisFunc _ _ nextFunc) = do+ Atom symCallfunc <- _gensym "lambdaFuncEntryPt"++-- TODO: need to extend Env below when compiling body?+-- TODO: need to bind lambda params in the extended env, for purposes of macro processing++ compiledBody <- compileBlock symCallfunc Nothing env [] fbody++ -- Entry point; ensure var is not rebound+ f <- return $ [AstValue $ " bound <- liftIO $ isRecBound env \"lambda\"",+ AstValue $ " if bound ",+ AstValue $ " then throwError $ NotImplemented \"prepareApply env cont args\" ", -- if is bound to a variable in this scope; call into it+ AstValue $ " else do result <- makeHVarargs (" ++ astToHaskellStr varargs ++ ") env [] " ++ symCallfunc,+ createAstCont copts "result" " "+ ]+ return $ [createAstFunc copts f] ++ compiledBody+compile env args@(List [Atom "string-set!", Atom var, i, character]) copts = do+ Atom symDefine <- _gensym "stringSetFunc"+ Atom symMakeDefine <- _gensym "stringSetFuncMakeSet"++ entryPt <- compileSpecialFormEntryPoint "string-set!" symDefine copts+ compDefine <- compileExpr env i symDefine $ Just symMakeDefine+ compMakeDefine <- return $ AstFunction symMakeDefine " env cont idx _ " [+ AstValue $ " tmp <- getVar env \"" ++ var ++ "\"",+ -- TODO: not entirely correct below; should compile the character argument rather+ -- than directly inserting it into the compiled code...+ AstValue $ " result <- substr (tmp, (" ++ astToHaskellStr(character) ++ "), idx)",+ AstValue $ " _ <- setVar env \"" ++ var ++ "\" result",+ createAstCont copts "result" ""]+ return $ [entryPt] ++ compDefine ++ [compMakeDefine]+ -- TODO: eval env cont args@(List [Atom "string-set!" , nonvar , _ , _ ]) = do -- TODO: eval env cont fargs@(List (Atom "string-set!" : args)) = do --- TODO: eval env cont args@(List [Atom "set-car!", Atom var, argObj]) = do++compile env args@(List [Atom "set-car!", Atom var, argObj]) copts = do+ Atom symGetVar <- _gensym "setCarGetVar"+ Atom symCompiledObj <- _gensym "setCarCompiledObj"+ Atom symObj <- _gensym "setCarObj"+ Atom symDoSet <- _gensym "setCarDoSet"++ -- Code to all into next continuation from copts, if one exists+ let finalContinuation = case copts of+ (CompileOptions _ _ _ (Just nextFunc)) -> "continueEval e (makeCPS e c " ++ nextFunc ++ ")\n"+ _ -> "continueEval e c\n"++ -- Entry point that allows set-car! to be redefined+ entryPt <- compileSpecialFormEntryPoint "set-car!" symGetVar copts++ -- Function to read existing var+ compGetVar <- return $ AstFunction symGetVar " env cont idx _ " [+ AstValue $ " result <- getVar env \"" ++ var ++ "\"",+ AstValue $ " " ++ symObj ++ " env cont result Nothing "]++ -- Compiled version of argObj+ compiledObj <- compileExpr env argObj symCompiledObj Nothing ++ -- Function to check looked-up var and call into appropriate handlers; based on code from Core+ --+ -- This is so verbose because we need to have overloads of symObj to deal with many possible inputs.+ -- FUTURE: consider making these functions part of the runtime.+ compObj <- return $ AstValue $ "" +++ symObj ++ " :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal\n" +++ symObj ++ " _ _ obj@(List []) _ = throwError $ TypeMismatch \"pair\" obj\n" +++-- TODO: below, we want to make sure obj is of the right type. if so, compile obj and call into the "set" +-- function below to do the actual set-car+ symObj ++ " e c obj@(List (_ : _)) _ = " ++ symCompiledObj ++ " e (makeCPSWArgs e c " ++ symDoSet ++ " [obj]) (Nil \"\") Nothing\n" +++ symObj ++ " e c obj@(DottedList _ _) _ = " ++ symCompiledObj ++ " e (makeCPSWArgs e c " ++ symDoSet ++ " [obj]) (Nil \"\") Nothing\n" +++ symObj ++ " _ _ obj _ = throwError $ TypeMismatch \"pair\" obj\n"++ -- Function to do the actual (set!), based on code from Core+ --+ -- This is so verbose because we need to have overloads of symObj to deal with many possible inputs.+ -- FUTURE: consider making these functions part of the runtime.+ compDoSet <- return $ AstValue $ "" +++ symDoSet ++ " :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal\n" +++ symDoSet ++ " e c obj (Just [List (_ : ls)]) = setVar e \"" ++ var ++ "\" (List (obj : ls)) >>= " ++ finalContinuation +++ symDoSet ++ " e c obj (Just [DottedList (_ : ls) l]) = setVar e \"" ++ var ++ "\" (DottedList (obj : ls) l) >>= " ++ finalContinuation +++ symDoSet ++ " _ _ _ _ = throwError $ InternalError \"Unexpected argument to " ++ symDoSet ++ "\"\n"++ -- Return a list of all the compiled code+ return $ [entryPt, compGetVar, compObj, compDoSet] ++ compiledObj+ -- TODO: eval env cont args@(List [Atom "set-car!" , nonvar , _ ]) = do -- TODO: eval env cont fargs@(List (Atom "set-car!" : args)) = do--- TODO: eval env cont args@(List [Atom "set-cdr!", Atom var, argObj]) = do++compile env args@(List [Atom "set-cdr!", Atom var, argObj]) copts = do+ Atom symGetVar <- _gensym "setCdrGetVar"+ Atom symCompiledObj <- _gensym "setCdrCompiledObj"+ Atom symObj <- _gensym "setCdrObj"+ Atom symDoSet <- _gensym "setCdrDoSet"++ -- Code to all into next continuation from copts, if one exists+ let finalContinuation = case copts of+ (CompileOptions _ _ _ (Just nextFunc)) -> "continueEval e (makeCPS e c " ++ nextFunc ++ ")\n"+ _ -> "continueEval e c\n"++ -- Entry point that allows set-car! to be redefined+ entryPt <- compileSpecialFormEntryPoint "set-car!" symGetVar copts++ -- Function to read existing var+ compGetVar <- return $ AstFunction symGetVar " env cont idx _ " [+ AstValue $ " result <- getVar env \"" ++ var ++ "\"",+ AstValue $ " " ++ symObj ++ " env cont result Nothing "]++ -- Compiled version of argObj+ compiledObj <- compileExpr env argObj symCompiledObj Nothing ++ -- Function to check looked-up var and call into appropriate handlers; based on code from Core+ --+ -- This is so verbose because we need to have overloads of symObj to deal with many possible inputs.+ -- FUTURE: consider making these functions part of the runtime.+ compObj <- return $ AstValue $ "" +++ symObj ++ " :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal\n" +++ symObj ++ " _ _ obj@(List []) _ = throwError $ TypeMismatch \"pair\" obj\n" +++-- TODO: below, we want to make sure obj is of the right type. if so, compile obj and call into the "set" +-- function below to do the actual set-car+ symObj ++ " e c obj@(List (_ : _)) _ = " ++ symCompiledObj ++ " e (makeCPSWArgs e c " ++ symDoSet ++ " [obj]) (Nil \"\") Nothing\n" +++ symObj ++ " e c obj@(DottedList _ _) _ = " ++ symCompiledObj ++ " e (makeCPSWArgs e c " ++ symDoSet ++ " [obj]) (Nil \"\") Nothing\n" +++ symObj ++ " _ _ obj _ = throwError $ TypeMismatch \"pair\" obj\n"++ -- Function to do the actual (set!), based on code from Core+ --+ -- This is so verbose because we need to have overloads of symObj to deal with many possible inputs.+ -- FUTURE: consider making these functions part of the runtime.+ compDoSet <- return $ AstValue $ "" +++ symDoSet ++ " :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal\n" +++ symDoSet ++ " e c obj (Just [List (l : _)]) = setVar e \"" ++ var ++ "\" (DottedList [l] obj) >>= " ++ finalContinuation +++ symDoSet ++ " e c obj (Just [DottedList (l : _) _]) = setVar e \"" ++ var ++ "\" (DottedList [l] obj) >>= " ++ finalContinuation +++ symDoSet ++ " _ _ _ _ = throwError $ InternalError \"Unexpected argument to " ++ symDoSet ++ "\"\n"++ -- Return a list of all the compiled code+ return $ [entryPt, compGetVar, compObj, compDoSet] ++ compiledObj+ -- TODO: eval env cont args@(List [Atom "set-cdr!" , nonvar , _ ]) = do -- TODO: eval env cont fargs@(List (Atom "set-cdr!" : args)) = do--- TODO: eval env cont args@(List [Atom "vector-set!", Atom var, i, object]) = do+compile env args@(List [Atom "vector-set!", Atom var, i, object]) copts = do+ Atom symCompiledIdx <- _gensym "vectorSetIdx"+ Atom symCompiledObj <- _gensym "vectorSetObj"+ Atom symUpdateVec <- _gensym "vectorSetUpdate"+ Atom symIdxWrapper <- _gensym "vectorSetIdxWrapper"++ -- Entry point that allows this form to be redefined+ entryPt <- compileSpecialFormEntryPoint "vector-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 <- updateVector vec idx obj >>= setVar env \"" ++ var ++ "\"",+ createAstCont copts "result" ""]++ return $ [entryPt, compiledIdxWrapper, compiledUpdate] ++ compiledIdx ++ compiledObj+ -- TODO: eval env cont args@(List [Atom "vector-set!" , nonvar , _ , _]) = do -- TODO: eval env cont fargs@(List (Atom "vector-set!" : args)) = do + -- TODO: eval env cont args@(List [Atom "hash-table-set!", Atom var, rkey, rvalue]) = do -- TODO: eval env cont args@(List [Atom "hash-table-set!" , nonvar , _ , _]) = do -- TODO: eval env cont fargs@(List (Atom "hash-table-set!" : args)) = do@@ -372,6 +573,22 @@ mfunc env cont lisp func = do Language.Scheme.Macro.macroEval env lisp >>= (func env cont) -}+++-- TODO: a helper function to allow special forms to be redefined at runtime...+compileSpecialFormEntryPoint :: String -> String -> CompOpts -> IOThrowsError HaskAST+compileSpecialFormEntryPoint formName formSym copts = do+ compileSpecialForm formName ("do " ++ formSym ++ " env cont (Nil \"\") []") copts++compileSpecialForm :: String -> String -> CompOpts -> IOThrowsError HaskAST+compileSpecialForm formName formCode copts = do+ f <- return $ [AstValue $ " bound <- liftIO $ isRecBound env \"" ++ formName ++ "\"",+ AstValue $ " if bound ",+ AstValue $ " then throwError $ NotImplemented \"prepareApply env cont args\" ", -- if is bound to a variable in this scope; call into it+ AstValue $ " else " ++ formCode]+ return $ createAstFunc copts f++ -- Compile an intermediate expression (such as an arg to if) and -- call into the next continuation with it's value
hs-src/Language/Scheme/Core.hs view
@@ -19,6 +19,8 @@ , apply , continueEval , showBanner+ , substr+ , updateVector , version ) where import qualified Language.Scheme.FFI@@ -31,10 +33,11 @@ import Control.Monad.Error import Data.Array import qualified Data.Map+import qualified System.Exit import System.IO version :: String-version = "3.5.2.3"+version = "3.5.3" showBanner :: IO () showBanner = do@@ -291,29 +294,35 @@ cpsUnquoteFld _ _ _ _ = throwError $ InternalError "Unexpected parameters to cpsUnquoteFld" -- A rudimentary implementation of let-syntax-eval env cont (List (Atom "let-syntax" : List _bindings : _body)) = do- -- TODO: check if let-syntax has been rebound?- bodyEnv <- liftIO $ extendEnv env []- _ <- Language.Scheme.Macro.loadMacros env bodyEnv Nothing False _bindings- -- Expand whole body as a single continuous macro, to ensure hygiene- expanded <- Language.Scheme.Macro.expand bodyEnv False $ List _body - case expanded of- List e -> continueEval bodyEnv (Continuation bodyEnv (Just $ SchemeBody e) (Just cont) Nothing Nothing) $ Nil "" - e -> continueEval bodyEnv cont e+eval env cont args@(List (Atom "let-syntax" : List _bindings : _body)) = 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 + bodyEnv <- liftIO $ extendEnv env []+ _ <- Language.Scheme.Macro.loadMacros env bodyEnv Nothing False _bindings+ -- Expand whole body as a single continuous macro, to ensure hygiene+ expanded <- Language.Scheme.Macro.expand bodyEnv False $ List _body + case expanded of+ List e -> continueEval bodyEnv (Continuation bodyEnv (Just $ SchemeBody e) (Just cont) Nothing Nothing) $ Nil "" + e -> continueEval bodyEnv cont e -eval env cont (List (Atom "letrec-syntax" : List _bindings : _body)) = do- -- TODO: check if letrec-syntax has been rebound?- bodyEnv <- liftIO $ extendEnv env []- -- A primitive means of implementing letrec, by simply assuming that each macro is defined in- -- the letrec's environment, instead of the parent env. Not sure if this is 100% correct but it- -- is good enough to pass the R5RS test case so it will be used as a rudimentary implementation - -- for now...- _ <- Language.Scheme.Macro.loadMacros bodyEnv bodyEnv Nothing False _bindings- -- Expand whole body as a single continuous macro, to ensure hygiene- expanded <- Language.Scheme.Macro.expand bodyEnv False $ List _body - case expanded of- List e -> continueEval bodyEnv (Continuation bodyEnv (Just $ SchemeBody e) (Just cont) Nothing Nothing) $ Nil "" - e -> continueEval bodyEnv cont e+eval env cont args@(List (Atom "letrec-syntax" : List _bindings : _body)) = 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 + bodyEnv <- liftIO $ extendEnv env []+ -- A primitive means of implementing letrec, by simply assuming that each macro is defined in+ -- the letrec's environment, instead of the parent env. Not sure if this is 100% correct but it+ -- is good enough to pass the R5RS test case so it will be used as a rudimentary implementation + -- for now...+ _ <- Language.Scheme.Macro.loadMacros bodyEnv bodyEnv Nothing False _bindings+ -- Expand whole body as a single continuous macro, to ensure hygiene+ expanded <- Language.Scheme.Macro.expand bodyEnv False $ List _body + case expanded of+ List e -> continueEval bodyEnv (Continuation bodyEnv (Just $ SchemeBody e) (Just cont) Nothing Nothing) $ Nil "" + e -> continueEval bodyEnv cont e eval env cont args@(List [Atom "define-syntax", Atom keyword, (List (Atom "syntax-rules" : (List identifiers : rules)))]) = do bound <- liftIO $ isRecBound env "define-syntax"@@ -437,13 +446,6 @@ substr (str, character, idx) >>= setVar e var >>= continueEval e c cpsSubStr _ _ _ _ = throwError $ InternalError "Invalid argument to cpsSubStr" - substr (String str, Char char, Number ii) = do- return $ String $ (take (fromInteger ii) . drop 0) str ++- [char] ++- (take (length str) . drop (fromInteger ii + 1)) str- substr (String _, Char _, n) = throwError $ TypeMismatch "number" n- substr (String _, c, _) = throwError $ TypeMismatch "character" c- substr (s, _, _) = throwError $ TypeMismatch "string" s eval env cont args@(List [Atom "string-set!" , nonvar , _ , _ ]) = do bound <- liftIO $ isRecBound env "string-set!" if bound@@ -527,9 +529,6 @@ updateVector vec idx obj >>= setVar e var >>= continueEval e c cpsUpdateVec _ _ _ _ = throwError $ InternalError "Invalid argument to cpsUpdateVec" - updateVector :: LispVal -> LispVal -> LispVal -> IOThrowsError LispVal- updateVector (Vector vec) (Number idx) obj = return $ Vector $ vec // [(fromInteger idx, obj)]- updateVector v _ _ = throwError $ TypeMismatch "vector" v eval env cont args@(List [Atom "vector-set!" , nonvar , _ , _]) = do bound <- liftIO $ isRecBound env "vector-set!" if bound@@ -602,6 +601,21 @@ eval env cont args@(List (_ : _)) = mprepareApply env cont args eval _ _ badForm = throwError $ BadSpecialForm "Unrecognized special form" badForm +-- |A helper function for the special form (string-set!)+substr :: (LispVal, LispVal, LispVal) -> IOThrowsError LispVal +substr (String str, Char char, Number ii) = do+ return $ String $ (take (fromInteger ii) . drop 0) str +++ [char] +++ (take (length str) . drop (fromInteger ii + 1)) str+substr (String _, Char _, n) = throwError $ TypeMismatch "number" n+substr (String _, c, _) = throwError $ TypeMismatch "character" c+substr (s, _, _) = throwError $ TypeMismatch "string" s++-- |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)]+updateVector v _ _ = throwError $ TypeMismatch "vector" v+ {- Prepare for apply by evaluating each function argument, and then execute the function via 'apply' -} prepareApply :: Env -> LispVal -> LispVal -> IOThrowsError LispVal@@ -749,7 +763,7 @@ {- These functions have access to the current environment via the current continuation, which is passed as the first LispVal argument. -} ---evalfuncApply, evalfuncDynamicWind, evalfuncEval, evalfuncLoad, evalfuncCallCC, evalfuncCallWValues :: [LispVal] -> IOThrowsError LispVal+evalfuncExitSuccess, evalfuncExitFail, evalfuncApply, evalfuncDynamicWind, evalfuncEval, evalfuncLoad, evalfuncCallCC, evalfuncCallWValues :: [LispVal] -> IOThrowsError LispVal {- - A (somewhat) simplified implementation of dynamic-wind@@ -851,6 +865,13 @@ evalfuncCallCC (_ : args) = throwError $ NumArgs 1 args -- Skip over continuation argument evalfuncCallCC _ = throwError $ NumArgs 1 [] +evalfuncExitFail _ = do+ _ <- liftIO $ System.Exit.exitFailure+ return $ Nil ""+evalfuncExitSuccess _ = do+ _ <- liftIO $ System.Exit.exitSuccess+ return $ Nil ""+ {- Primitive functions that extend the core evaluator -} evalFunctions :: [(String, [LispVal] -> IOThrowsError LispVal)] evalFunctions = [ ("apply", evalfuncApply)@@ -859,7 +880,10 @@ , ("dynamic-wind", evalfuncDynamicWind) , ("eval", evalfuncEval) , ("load", evalfuncLoad)- , ("load-ffi", Language.Scheme.FFI.evalfuncLoadFFI) -- Non-standard extension+ -- Non-standard extensions+ , ("load-ffi", Language.Scheme.FFI.evalfuncLoadFFI)+ , ("exit-fail", evalfuncExitFail)+ , ("exit-success", evalfuncExitSuccess) ] {- I/O primitives Primitive functions that execute within the IO monad -}
hs-src/Language/Scheme/FFI.hs view
@@ -59,13 +59,20 @@ #if __GLASGOW_HASKELL__ < 700 GHC.setContext [] [m] #elif __GLASGOW_HASKELL__ == 702- (_,oi) <- GHC.getContext- GHC.setContext [m] oi+ -- Fix from dflemstr:+ -- http://stackoverflow.com/questions/9198140/ghc-api-how-to-dynamically-load-haskell-code-from-a-compiled-module-using-ghc+ GHC.setContext [] + -- import qualified Module+ [ (GHC.simpleImportDecl . GHC.mkModuleName $ moduleName)+ {GHC.ideclQualified = True}+ ] #elif __GLASGOW_HASKELL__ >= 704--- TODO:--- interactImport <- GHC.getContext--- GHC.setContext $ [GHC.IIModule m]--- GHC.setContext $ interactImport ++ [GHC.IIModule m]+ GHC.setContext + -- import qualified Module+ [ GHC.IIDecl $ + (GHC.simpleImportDecl . GHC.mkModuleName $ moduleName)+ {GHC.ideclQualified = True}+ ] #else GHC.setContext [] [(m, Nothing)] #endif@@ -82,17 +89,24 @@ #if __GLASGOW_HASKELL__ < 700 GHC.setContext [] [m] #elif __GLASGOW_HASKELL__ == 702- (_,oi) <- GHC.getContext- GHC.setContext [m] oi+ -- Fix from dflemstr:+ -- http://stackoverflow.com/questions/9198140/ghc-api-how-to-dynamically-load-haskell-code-from-a-compiled-module-using-ghc+ GHC.setContext [] + -- import qualified Module+ [ (GHC.simpleImportDecl . GHC.mkModuleName $ moduleName)+ {GHC.ideclQualified = True}+ ] #elif __GLASGOW_HASKELL__ >= 704--- TODO:--- interactImport <- GHC.getContext--- GHC.setContext $ [GHC.IIModule m]--- GHC.setContext $ interactImport ++ [GHC.IIModule m]+ GHC.setContext + -- import qualified Module+ [ GHC.IIDecl $ + (GHC.simpleImportDecl . GHC.mkModuleName $ moduleName)+ {GHC.ideclQualified = True}+ ] #else GHC.setContext [] [(m, Nothing)] #endif- fetched <- GHC.compileExpr (moduleName ++ "." ++ externalFuncName)+ fetched <- GHC.compileExpr $ moduleName ++ "." ++ externalFuncName return (Unsafe.Coerce.unsafeCoerce fetched :: [LispVal] -> IOThrowsError LispVal) defineVar env internalFuncName (IOFunc result) -- >>= continueEval env cont
husk-scheme.cabal view
@@ -1,5 +1,5 @@ Name: husk-scheme-Version: 3.5.2.3+Version: 3.5.3 Synopsis: R5RS Scheme interpreter, compiler, and library. Description: A dialect of R5RS Scheme written in Haskell. Provides advanced features including continuations, hygienic macros, a Haskell FFI,
stdlib.scm view
@@ -368,6 +368,19 @@ (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)