husk-scheme 3.5.1 → 3.5.2
raw patch · 7 files changed
+712/−130 lines, 7 filesdep +filepathdep +haskell98dep +husk-schemenew-component:exe:huskc
Dependencies added: filepath, haskell98, husk-scheme, process
Files
- hs-src/Compiler/huskc.hs +151/−0
- hs-src/Interpreter/shell.hs +86/−0
- hs-src/Language/Scheme/Compiler.hs +431/−0
- hs-src/Language/Scheme/Core.hs +25/−15
- hs-src/shell.hs +0/−100
- husk-scheme.cabal +14/−15
- stdlib.scm +5/−0
+ hs-src/Compiler/huskc.hs view
@@ -0,0 +1,151 @@+{- |+Module : Main+Copyright : Justin Ethier+Licence : MIT (see LICENSE in the distribution)++Maintainer : github.com/justinethier+Stability : experimental+Portability : portable++A front-end for an experimental compiler+-}++module Main where+import Paths_husk_scheme+import Language.Scheme.Compiler+import qualified Language.Scheme.Core+import Language.Scheme.Types -- Scheme data types+import Language.Scheme.Variables -- Scheme variable operations+import Control.Monad.Error+import System (getArgs)+import System.Cmd (system)+import System.Console.GetOpt+import System.FilePath (dropExtension)+import System.Environment+import System.Exit (ExitCode (..), exitWith, exitFailure)+import System.IO++main :: IO ()+main = do ++ putStrLn ""+ putStrLn "!!! This version of huskc is Experimental !!!"+ putStrLn ""+ putStrLn "It is recommended you consult the issue list prior to use:"+ putStrLn "https://github.com/justinethier/husk-scheme/issues"+ putStrLn ""++ -- Read command line args and process options+ args <- getArgs+ let (actions, nonOpts, msgs) = getOpt Permute options args+ opts <- foldl (>>=) (return defaultOptions) actions+ let Options {optOutput = output} = opts++ if null nonOpts+ then showUsage+ else do+ let inFile = nonOpts !! 0+ outExec = case output of+ Just inFile -> inFile+ Nothing -> dropExtension inFile+ process inFile outExec++-- +-- For an explanation of the command line options code, see:+-- http://leiffrenzel.de/papers/commandline-options-in-haskell.html+--++-- |Data type to handle command line options that take parameters+data Options = Options {+ optOutput :: Maybe String -- Executable file to write+ }++-- |Default values for the command line options+defaultOptions :: Options+defaultOptions = Options {+ optOutput = Nothing + }++-- |Command line options+options :: [OptDescr (Options -> IO Options)]+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"+ ]++-- |Determine executable file to write. +-- This version just takes a name from the command line option+writeExec arg opt = return opt { optOutput = Just arg }++-- TODO: would nice to have this as well as a 'real' usage printout, perhaps via --help++-- |Print a usage message+showUsage :: IO ()+showUsage = do+ putStrLn "huskc: no input files"++showHelp :: Options -> IO Options+showHelp _ = do+ putStrLn "Usage: huskc [options] file"+ putStrLn ""+ putStrLn "Options:"+ putStrLn " --help Display this information"+ putStrLn " --version Display husk version information"+ putStrLn " --output filename Write executable to the given filename"+ putStrLn ""+ exitWith ExitSuccess++-- |Print version information+showVersion :: Options -> IO Options+showVersion _ = do+ putStrLn Language.Scheme.Core.version+-- TODO: would be nice to be able to print the banner: Language.Scheme.Core.showBanner+ exitWith ExitSuccess++-- |High level code to compile the given file+process :: String -> String -> IO ()+process inFile outExec = do+ env <- liftIO $ nullEnv+ stdlib <- getDataFileName "stdlib.scm"+ result <- (runIOThrows $ liftM show $ compileSchemeFile env stdlib inFile)+ case result of+ "" -> compileHaskellFile outExec+ _ -> putStrLn result++-- |Compile a scheme file to haskell+compileSchemeFile :: Env -> String -> String -> IOThrowsError LispVal+compileSchemeFile env stdlib filename = 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 "exec")+ execC <- compileLisp env filename "exec" Nothing+ outH <- liftIO $ openFile "_tmp.hs" WriteMode+ _ <- liftIO $ writeList outH header+ _ <- liftIO $ writeList outH $ map show libsC+ _ <- liftIO $ writeList outH $ map show execC+ _ <- liftIO $ hClose outH+ if not (null execC)+ then return $ Nil "" -- Dummy value+ else throwError $ Default "Empty file" --putStrLn "empty file"++-- |Compile the intermediate haskell file using GHC+compileHaskellFile :: String -> IO() --ThrowsError LispVal+compileHaskellFile filename = do+ let ghc = "ghc" -- Need to make configurable??+ compileStatus <- system $ ghc ++ " -cpp --make -package ghc -fglasgow-exts -o " ++ filename ++ " _tmp.hs"++-- TODO: delete intermediate hs files if requested++ case compileStatus of+ ExitFailure _code -> exitWith compileStatus+ ExitSuccess -> return ()++-- |Helper function to write a list of abstract Haskell code to file+writeList outH (l : ls) = do+ hPutStrLn outH l+ writeList outH ls+writeList outH _ = do+ hPutStr outH ""++
+ hs-src/Interpreter/shell.hs view
@@ -0,0 +1,86 @@+{- |+Module : Main+Copyright : Justin Ethier+Licence : MIT (see LICENSE in the distribution)++Maintainer : github.com/justinethier+Stability : experimental+Portability : portable++This file implements a REPL "shell" to host the interpreter, and also+allows execution of stand-alone files containing Scheme code.+-}++module Main where+import Paths_husk_scheme+import Language.Scheme.Core -- Scheme Interpreter+import Language.Scheme.Types -- Scheme data types+import Language.Scheme.Variables -- Scheme variable operations+import Control.Monad.Error+import System.IO+import System.Environment+import System.Console.Haskeline++main :: IO ()+main = do args <- getArgs+ if null args then do showBanner+ runRepl+ else runOne $ args++-- REPL Section+flushStr :: String -> IO ()+flushStr str = putStr str >> hFlush stdout++runOne :: [String] -> IO ()+runOne args = do+ {- Use this to suppress unwanted output.+ Makes this unix-specific, but as of now+ everything else is anyway, so... -}+ nullIO <- openFile "/dev/null" WriteMode++ stdlib <- getDataFileName "stdlib.scm"+ env <- primitiveBindings >>= flip extendEnv+ [((varNamespace, "args"),+ List $ map String $ drop 1 args)]+ _ <- evalString env $ "(load \"" ++ stdlib ++ "\")" -- Load standard library+ (runIOThrows $ liftM show $ evalLisp env (List [Atom "load", String (args !! 0)]))+ >>= hPutStr nullIO++ -- Call into (main) if it exists...+ alreadyDefined <- liftIO $ isBound env "main"+ let argv = List $ map String $ args+ if alreadyDefined+ then (runIOThrows $ liftM show $ evalLisp env+ (List [Atom "main", List [Atom "quote", argv]])) >>= hPutStr stderr+ else (runIOThrows $ liftM show $ evalLisp env (Nil "")) >>= hPutStr stderr++runRepl :: IO ()+runRepl = do+ stdlib <- getDataFileName "stdlib.scm"+ env <- primitiveBindings+ _ <- evalString env $ "(load \"" ++ stdlib ++ "\")" -- Load standard library into the REPL+ runInputT defaultSettings (loop env)+ where+ loop :: Env -> InputT IO ()+ loop env = do+ minput <- getInputLine "huski> "+ case minput of+ Nothing -> return ()+ Just "quit" -> return ()+ Just "" -> loop env -- FUTURE: integrate with strip to ignore inputs of just whitespace+ Just input -> do result <- liftIO (evalString env input)+ if (length result) > 0+ then do outputStrLn result+ loop env+ else loop env+-- End REPL Section++-- Begin Util section, of generic functions++{- Remove leading/trailing white space from a string; based on corresponding Python function+ Code taken from: http://gimbo.org.uk/blog/2007/04/20/splitting-a-string-in-haskell/ -}+strip :: String -> String+strip s = dropWhile ws $ reverse $ dropWhile ws $ reverse s+ where ws = (`elem` [' ', '\n', '\t', '\r'])++-- End Util
+ hs-src/Language/Scheme/Compiler.hs view
@@ -0,0 +1,431 @@++-- TODO items: lambda params, define, a simple test suite++{- |+Module : Language.Scheme.Core+Copyright : Justin Ethier+Licence : MIT (see LICENSE in the distribution)++Maintainer : github.com/justinethier+Stability : experimental+Portability : portable++This module contains an experimental compiler of Scheme to Haskell ++The compiler performs the following transformations:+Scheme AST (LispVal) -> Haskell AST (HaskAST) -> Compiled Code (String)+-}++module Language.Scheme.Compiler where +import qualified Language.Scheme.Macro+import Language.Scheme.Numerical+import Language.Scheme.Parser+import Language.Scheme.Primitives+import Language.Scheme.Types+import Language.Scheme.Variables+import Control.Monad.Error+import qualified Data.Array+import Data.Complex+import qualified Data.List+import Data.Ratio+import System.IO+import Debug.Trace++-- A type to store options passed to compile+-- eventually all of this might be able to be integrated into a Compile monad+data CompOpts = CompileOptions {+ coptsThisFunc :: String,+ coptsThisFuncUseValue :: Bool,+ coptsThisFuncUseArgs :: Bool,+ coptsNextFunc :: Maybe String+ }+--DefaultCompileOptions :: String -> CompileOpts +defaultCompileOptions :: String -> CompOpts+defaultCompileOptions thisFunc = CompileOptions thisFunc False False Nothing++createAstFunc :: CompOpts -> [HaskAST] -> HaskAST +createAstFunc (CompileOptions thisFunc useVal useArgs _) body = do+ let val = case useVal of+ True -> "value"+ _ -> "_"+ args = case useArgs of+ True -> "(Just args)"+ _ -> "_"+ AstFunction thisFunc (" env cont " ++ val ++ " " ++ args ++ " ") body++createAstCont :: CompOpts -> String -> String -> HaskAST+createAstCont (CompileOptions _ _ _ (Just nextFunc)) var indentation = do+ AstValue $ indentation ++ " continueEval env (makeCPS env cont " ++ nextFunc ++ ") " ++ var+createAstCont (CompileOptions _ _ _ Nothing) var indentation = do+ AstValue $ indentation ++ " continueEval env cont " ++ var++-- A very basic type to store a Haskell AST+data HaskAST = AstAssignM String HaskAST+ | AstFunction {astfName :: String,+-- astfType :: String,+ astfArgs :: String,+ astfCode :: [HaskAST]+ } + | AstValue String+ | AstContinuation {astcNext :: String,+ astcArgs :: String+ }++showValAST :: HaskAST -> String+showValAST (AstAssignM var val) = " " ++ var ++ " <- " ++ show val+showValAST (AstFunction name args code) = do+ let header = "\n" ++ name ++ args ++ " = do "+ let body = unwords . map (\x -> "\n" ++ x ) $ map showValAST code+ header ++ body +showValAST (AstValue v) = v++-- TODO: this is too limiting, this is an 'internal' continuation. most should take a value and pass it along, not args+showValAST (AstContinuation nextFunc args) = " continueEval env (makeCPSWArgs env cont " ++ nextFunc ++ " " ++ args ++ ") $ Nil \"\""++instance Show HaskAST where show = showValAST++joinL ls sep = concat $ Data.List.intersperse sep ls++astToHaskellStr :: LispVal -> String +astToHaskellStr (String s) = "String " ++ show s+astToHaskellStr (Char c) = "Char " ++ show c+astToHaskellStr (Atom a) = "Atom " ++ show a+astToHaskellStr (Number n) = "Number (" ++ show n ++ ")"+astToHaskellStr (Complex c) = "Complex $ (" ++ (show $ realPart c) ++ ") :+ (" ++ (show $ imagPart c) ++ ")"+astToHaskellStr (Rational r) = "Rational $ (" ++ (show $ numerator r) ++ ") % (" ++ (show $ denominator r) ++ ")"+astToHaskellStr (Float f) = "Float (" ++ show f ++ ")"+astToHaskellStr (Bool True) = "Bool True"+astToHaskellStr (Bool False) = "Bool False"+astToHaskellStr (Vector v) = do+ let ls = Data.Array.elems v+ size = (length ls) - 1+ "Vector (listArray (0, " ++ show size ++ ")" ++ "[" ++ joinL (map astToHaskellStr ls) "," ++ "])"+astToHaskellStr (List ls) = "List [" ++ joinL (map astToHaskellStr ls) "," ++ "]"+astToHaskellStr (DottedList ls l) = + "DottedList [" ++ joinL (map astToHaskellStr ls) "," ++ "] $ " ++ astToHaskellStr l++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 "+ , "import Language.Scheme.Types -- Scheme data types "+ , "import Language.Scheme.Variables -- Scheme variable operations "+ , "import Control.Monad.Error "+ , "import Data.Array "+ , "import Data.Complex "+ , "import Data.Ratio "+ , "import System.IO "+ , " "+-- TODO: eventually these make func's will be moved out into their own module+ , ""+ , "--makeNormalFunc :: Env -> [LispVal] -> String -> IOThrowsError LispVal "+ , "makeHFunc ::"+ , " (Monad m) =>"+ , " Maybe String "+ , " -> Env "+ , " -> [String] "+ , " -> (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal) "+ , "-- -> String "+ , " -> m LispVal"+ , "makeHFunc varargs env fparams fbody = return $ HFunc fparams varargs fbody env --(map showVal fparams) varargs fbody env"+ , "makeNormalHFunc :: (Monad m) =>"+ , " Env"+ , " -> [String]"+ , " -> (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)"+ , " -> m LispVal"+ , "makeNormalHFunc = makeHFunc Nothing"+ , "makeHVarargs :: (Monad m) => LispVal "+ , " -> Env"+ , " -> [String]"+ , " -> (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)"+ , " -> m LispVal"+ , "makeHVarargs = makeHFunc . Just . showVal"+ , "main :: IO () "+ , "main = do "+ , " env <- primitiveBindings "+ , " (runIOThrows $ liftM show $ run env (makeNullContinuation env) (Nil \"\") Nothing) >>= putStr "+ , " "]++-- NOTE: the following type is used for all functions generated by the compiler: +-- , "run :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal "++compileLisp :: Env -> String -> String -> Maybe String -> IOThrowsError [HaskAST]+compileLisp env filename entryPoint exitPoint = load filename >>= compileBlock entryPoint exitPoint env []+-- compileBlock+--+-- Note: Uses explicit recursion to transform a block of code, because+-- later lines may depend on previous ones+compileBlock :: String -> Maybe String -> Env -> [HaskAST] -> [LispVal] -> IOThrowsError [HaskAST]+compileBlock symThisFunc symLastFunc env result code@[c] = do+ compiled <- mcompile env c $ CompileOptions symThisFunc False False symLastFunc + return $ result ++ compiled+compileBlock symThisFunc symLastFunc env result code@(c:cs) = do+ Atom symNextFunc <- _gensym "f"+ compiled <- mcompile env c $ CompileOptions symThisFunc False False (Just symNextFunc)+ compileBlock symNextFunc symLastFunc env (result ++ compiled) cs+compileBlock _ _ _ result [] = return result++-- TODO: could everything just be regular function calls except when a continuation is 'added to the stack' via a makeCPS(makeCPSWArgs ...) ?? I think this could be made more efficient++-- Helper function to compile expressions consisting of a scalar+compileScalar :: String -> CompOpts -> IOThrowsError [HaskAST]+compileScalar val copts = do + f <- return $ AstAssignM "x1" $ AstValue val + c <- return $ createAstCont copts "x1" ""+ return [createAstFunc copts [f, c]]++compileLambdaList :: [LispVal] -> IOThrowsError String+compileLambdaList l = do+ serialized <- mapM serialize l + return $ "[" ++ concat (Data.List.intersperse "," serialized) ++ "]"+ where serialize (Atom a) = return $ (show a)+ --serialize _ = throwError $ Default "invalid parameter to lambda list. TODO: output var"++compile :: Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]+compile _ (Nil n) copts = compileScalar (" return $ Nil " ++ (show n)) copts+compile _ (String s) copts = compileScalar (" return $ String " ++ (show s)) copts+compile _ (Char c) copts = compileScalar (" return $ Char " ++ (show c)) copts+compile _ (Complex c) copts = compileScalar (" return $ Complex $ (" ++ (show $ realPart c) ++ ") :+ (" ++ (show $ imagPart c) ++ ")") copts+compile _ (Float f) copts = compileScalar (" return $ Float (" ++ (show f) ++ ")") copts+compile _ (Rational r) copts = compileScalar (" return $ Rational $ (" ++ (show $ numerator r) ++ ") % (" ++ (show $ denominator r) ++ ")") copts +compile _ (Number n) copts = compileScalar (" return $ Number (" ++ (show n) ++ ")") copts+compile _ (Bool b) copts = compileScalar (" return $ Bool " ++ (show b)) copts+-- TODO: eval env cont val@(HashTable _) = continueEval env cont val+compile _ v@(Vector _) copts = compileScalar (" return $ " ++ astToHaskellStr v) copts+compile _ (Atom a) copts = compileScalar (" getVar env \"" ++ a ++ "\"") copts ++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++compile env args@(List [Atom "define-syntax", Atom keyword, (List (Atom "syntax-rules" : (List identifiers : rules)))]) copts = do+--+-- TODO:+--+-- macros will eventually need to introduce a definition in both the compiler's env (so macros can be processed at compile time) and in the program's env (so dynamically injected code has access to the macro). That said, the priority is compile-time processing.+--+-- TBD: how the heck to serialize a Syntax object for use in the compiled code, since+-- Syntax has embedded env's... perhaps the first step is to do it with a null env+--+ _ <- defineNamespacedVar env macroNamespace keyword $ Syntax (Just env) Nothing False identifiers rules+ compileScalar (" return $ Nil \"\"") copts ++compile env args@(List [Atom "if", predic, conseq]) copts = + 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+ Atom symPredicate <- _gensym "ifPredic"+ Atom symCheckPredicate <- _gensym "compiledIfPredicate"+ Atom symConsequence <- _gensym "compiledConsequence"+ Atom symAlternate <- _gensym "compiledAlternative"+ -- Entry point; ensure if is not rebound+ f <- return $ [AstValue $ " bound <- liftIO $ isRecBound env \"if\"",+ 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 " ++ symPredicate ++ " env (makeCPS env cont " ++ symCheckPredicate ++ ") (Nil \"\") [] "+ ]+ -- Compile expression for if's args+ compPredicate <- compileExpr env predic symPredicate Nothing -- Do not want to call into nextFunc in the middle of (if)+ compConsequence <- compileExpr env conseq symConsequence nextFunc -- pick up at nextFunc after consequence+ compAlternate <- compileExpr env alt symAlternate nextFunc -- or...pick up at nextFunc after alternate+ -- Special case because we need to check the predicate's value+ compCheckPredicate <- return $ AstFunction symCheckPredicate " env cont result _ " [+ AstValue $ " case result of ",+ AstValue $ " Bool False -> " ++ symAlternate ++ " env cont (Nil \"\") [] ",+ AstValue $ " _ -> " ++ symConsequence ++ " env cont (Nil \"\") [] "]+ -- Join compiled code together+ return $ [createAstFunc copts f] ++ compPredicate ++ [compCheckPredicate] ++ compConsequence ++ compAlternate++compile env args@(List [Atom "set!", Atom var, form]) copts@(CompileOptions thisFunc _ _ nextFunc) = do+ Atom symDefine <- _gensym "setFunc"+ Atom symMakeDefine <- _gensym "setFuncMakeSet"++-- TODO: need to store var in huskc's env for macro processing++ -- 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 \"\") []" ]+ 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]++-- TODO: eval env cont args@(List [Atom "set!", nonvar, _]) = do +-- TODO: eval env cont fargs@(List (Atom "set!" : args)) = do++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)++ -- Entry point; ensure var is not rebound+ f <- return $ [AstValue $ " bound <- liftIO $ isRecBound env \"define\"",+ 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 \"\") []" ]+ compDefine <- compileExpr env form symDefine $ Just symMakeDefine+ compMakeDefine <- return $ AstFunction symMakeDefine " env cont result _ " [+ AstValue $ " _ <- defineVar env \"" ++ var ++ "\" result",+ createAstCont copts "result" ""]+ return $ [createAstFunc copts f] ++ compDefine ++ [compMakeDefine]++compile env args@(List (Atom "define" : List (Atom var : fparams) : fbody)) copts@(CompileOptions thisFunc _ _ nextFunc) = do+ Atom symCallfunc <- _gensym "defineFuncEntryPt"+ compiledParams <- compileLambdaList fparams+ compiledBody <- compileBlock symCallfunc Nothing env [] fbody++ -- Entry point; ensure var is not rebound+ f <- return $ [AstValue $ " bound <- liftIO $ isRecBound env \"define\"",+ 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 <- makeNormalHFunc env (" ++ compiledParams ++ ") " ++ symCallfunc,+ AstValue $ " _ <- defineVar env \"" ++ var ++ "\" result ",+ createAstCont copts "result" " "+ ]+ return $ [createAstFunc copts f] ++ compiledBody++compile env args@(List (Atom "define" : DottedList (Atom var : fparams) varargs : fbody)) copts@(CompileOptions thisFunc _ _ nextFunc) = do+ Atom symCallfunc <- _gensym "defineFuncEntryPt"+ compiledParams <- compileLambdaList fparams+ compiledBody <- compileBlock symCallfunc Nothing env [] fbody++ -- Entry point; ensure var is not rebound+ f <- return $ [AstValue $ " bound <- liftIO $ isRecBound env \"define\"",+ 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,+ AstValue $ " _ <- defineVar env \"" ++ var ++ "\" result ",+ createAstCont copts "result" " "+ ]+ return $ [createAstFunc copts f] ++ compiledBody++++compile env args@(List (Atom "lambda" : List fparams : 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?++ compiledBody <- compileBlock symCallfunc Nothing env [] fbody++ -- Entry point; ensure var is not rebound+-- TODO: will probably end up creating a common function for this,+-- since it is almost the same as in "if"+ 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 <- makeNormalHFunc env (" ++ compiledParams ++ ") " ++ symCallfunc,+ createAstCont copts "result" " "+ ]+ return $ [createAstFunc copts f] ++ compiledBody++++-- 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+-- 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+-- 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+-- 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+-- 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+-- TODO: eval env cont args@(List [Atom "hash-table-delete!", Atom var, rkey]) = do+-- TODO: eval env cont fargs@(List (Atom "hash-table-delete!" : args)) = do++++compile env args@(List (_ : _)) copts = mfunc env args compileApply copts +compile _ badForm _ = throwError $ BadSpecialForm "Unrecognized special form" badForm++mcompile :: Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]+mcompile env lisp copts = mfunc env lisp compile copts+mfunc :: Env -> LispVal -> (Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]) -> CompOpts -> IOThrowsError [HaskAST] +mfunc env lisp func copts = do+ transformed <- Language.Scheme.Macro.macroEval env lisp + func env transformed copts+{- TODO: adapt for compilation+meval, mprepareApply :: Env -> LispVal -> LispVal -> IOThrowsError LispVal+meval env cont lisp = mfunc env cont lisp eval+mprepareApply env cont lisp = mfunc env cont lisp prepareApply+mfunc :: Env -> LispVal -> LispVal -> (Env -> LispVal -> LispVal -> IOThrowsError LispVal) -> IOThrowsError LispVal+mfunc env cont lisp func = do+ Language.Scheme.Macro.macroEval env lisp >>= (func env cont) +-}++-- Compile an intermediate expression (such as an arg to if) and +-- call into the next continuation with it's value+compileExpr :: Env -> LispVal -> String -> Maybe String -> IOThrowsError [HaskAST]+compileExpr env expr symThisFunc fForNextExpr = do+ mcompile env expr (CompileOptions symThisFunc False False fForNextExpr) ++-- |Compiles each argument to a function call, and then uses apply to call the function+compileApply :: Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]+compileApply env args@(List (func : params)) copts@(CompileOptions coptsThis _ _ coptsNext) = do+ Atom stubFunc <- _gensym "applyStubF"+ Atom wrapperFunc <- _gensym "applyWrapper"+ Atom nextFunc <- _gensym "applyNextF"++ c <- return $ AstFunction coptsThis " env cont _ _ " [AstValue $ " continueEval env (makeCPS env (makeCPS env cont " ++ wrapperFunc ++ ") " ++ stubFunc ++ ") $ Nil\"\""] + -- Use wrapper to pass high-order function (func) as an argument to apply+ wrapper <- return $ AstFunction wrapperFunc " env cont value _ " [AstValue $ " continueEval env (makeCPSWArgs env cont " ++ nextFunc ++ " [value]) $ Nil \"\""]+ _comp <- mcompile env func $ CompileOptions stubFunc False False Nothing+ rest <- compileArgs nextFunc False params -- False since no value passed in this time++ return $ [c, wrapper ] ++ _comp ++ rest+ where + -- TODO: this pattern may need to be extracted into a common place for use in other similar+ -- situations, such as params to a lambda expression+ compileArgs :: String -> Bool -> [LispVal] -> IOThrowsError [HaskAST]+ compileArgs thisFunc thisFuncUseValue args = do+ case args of+ [] -> do+ -- The basic idea is that if there is a next expression, call into it as a new continuation+ -- instead of calling into cont+ case coptsNext of+ Nothing -> return $ [+ AstFunction thisFunc + " env cont (Nil _) (Just (a:as)) " [AstValue " apply cont a as "],+ AstFunction thisFunc + " env cont value (Just (a:as)) " [AstValue " apply cont a $ as ++ [value] "]]+ Just fnextExpr -> return $ [+ AstFunction thisFunc + " env cont (Nil _) (Just (a:as)) " [AstValue $ " apply (makeCPS env cont " ++ fnextExpr ++ ") a as "],+ AstFunction thisFunc + " env cont value (Just (a:as)) " [AstValue $ " apply (makeCPS env cont " ++ fnextExpr ++ ") a $ as ++ [value] "]]+ (a:as) -> do+ Atom stubFunc <- _gensym "applyFirstArg" -- Call into compiled stub+ Atom nextFunc <- _gensym "applyNextArg" -- Next func argument to execute...+ _comp <- mcompile env a $ CompileOptions stubFunc False False Nothing++ -- Flag below means that the expression's value matters, add it to args+ f <- if thisFuncUseValue+ then return $ AstValue $ thisFunc ++ " env cont value (Just args) = do "+ else return $ AstValue $ thisFunc ++ " env cont _ (Just args) = do "+ c <- if thisFuncUseValue+ then return $ AstValue $ " continueEval env (makeCPS env (makeCPSWArgs env cont " ++ nextFunc ++ " $ args ++ [value]) " ++ stubFunc ++ ") $ Nil\"\"" + else return $ AstValue $ " continueEval env (makeCPS env (makeCPSWArgs env cont " ++ nextFunc ++ " args) " ++ stubFunc ++ ") $ Nil\"\"" ++ rest <- compileArgs nextFunc True as -- True indicates nextFunc needs to use value arg passed into it+ return $ [ f, c] ++ _comp ++ rest+
hs-src/Language/Scheme/Core.hs view
@@ -18,6 +18,8 @@ , primitiveBindings , apply , continueEval+ , showBanner+ , version ) where import qualified Language.Scheme.FFI import qualified Language.Scheme.Macro@@ -31,6 +33,24 @@ import qualified Data.Map import System.IO +version :: String+version = "3.5.2"++showBanner :: IO ()+showBanner = do+ putStrLn " _ _ __ _ "+ putStrLn " | | | | \\\\\\ | | "+ putStrLn " | |__ _ _ ___| | __ \\\\\\ ___ ___| |__ ___ _ __ ___ ___ "+ putStrLn " | '_ \\| | | / __| |/ / //\\\\\\ / __|/ __| '_ \\ / _ \\ '_ ` _ \\ / _ \\ "+ putStrLn " | | | | |_| \\__ \\ < /// \\\\\\ \\__ \\ (__| | | | __/ | | | | | __/ "+ putStrLn " |_| |_|\\__,_|___/_|\\_\\ /// \\\\\\ |___/\\___|_| |_|\\___|_| |_| |_|\\___| "+ putStrLn " "+ putStrLn " http://justinethier.github.com/husk-scheme "+ putStrLn " (c) 2010-2012 Justin Ethier "+ putStrLn $ " Version " ++ version ++ " "+ putStrLn " "++ {- |Evaluate a string containing Scheme code. For example:@@ -342,21 +362,6 @@ Bool False -> continueEval e c $ Nil "" -- Unspecified return value per R5RS _ -> meval e c conseq -eval env cont fargs@(List (Atom "begin" : funcs)) = do- bound <- liftIO $ isRecBound env "begin"- if bound- then prepareApply env cont fargs -- if is bound to a variable in this scope; call into it- else if length funcs == 0- then meval env cont (Nil "")- else if length funcs == 1- then meval env cont (head funcs)- else meval env (makeCPSWArgs env cont cpsRest $ tail funcs) (head funcs)- where cpsRest :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal- cpsRest e c _ args =- case args of- Just fArgs -> meval e c (List (Atom "begin" : fArgs))- Nothing -> throwError $ Default "Unexpected error in begin"- eval env cont args@(List [Atom "set!", Atom var, form]) = do bound <- liftIO $ isRecBound env "set!" if bound@@ -834,6 +839,11 @@ _ -> return result Func _ (Just _) _ _ -> apply cont func [cont] -- Variable # of args (pair). Just call into cont Func aparams _ _ _ ->+ if (toInteger $ length aparams) == 1+ then apply cont func [cont]+ else throwError $ NumArgs (toInteger $ length aparams) [cont]+ HFunc _ (Just _) _ _ -> apply cont func [cont] -- Variable # of args (pair). Just call into cont + HFunc aparams _ _ _ -> if (toInteger $ length aparams) == 1 then apply cont func [cont] else throwError $ NumArgs (toInteger $ length aparams) [cont]
− hs-src/shell.hs
@@ -1,100 +0,0 @@-{- |-Module : Main-Copyright : Justin Ethier-Licence : MIT (see LICENSE in the distribution)--Maintainer : github.com/justinethier-Stability : experimental-Portability : portable--This file implements a REPL "shell" to host the interpreter, and also-allows execution of stand-alone files containing Scheme code.--}--module Main where-import Paths_husk_scheme-import Language.Scheme.Core -- Scheme Interpreter-import Language.Scheme.Types -- Scheme data types-import Language.Scheme.Variables -- Scheme variable operations-import Control.Monad.Error-import System.IO-import System.Environment-import System.Console.Haskeline--main :: IO ()-main = do args <- getArgs- if null args then do showBanner- runRepl- else runOne $ args---- REPL Section-flushStr :: String -> IO ()-flushStr str = putStr str >> hFlush stdout--runOne :: [String] -> IO ()-runOne args = do- {- Use this to suppress unwanted output.- Makes this unix-specific, but as of now- everything else is anyway, so... -}- nullIO <- openFile "/dev/null" WriteMode-- stdlib <- getDataFileName "stdlib.scm"- env <- primitiveBindings >>= flip extendEnv- [((varNamespace, "args"),- List $ map String $ drop 1 args)]- _ <- evalString env $ "(load \"" ++ stdlib ++ "\")" -- Load standard library- (runIOThrows $ liftM show $ evalLisp env (List [Atom "load", String (args !! 0)]))- >>= hPutStr nullIO-- -- Call into (main) if it exists...- alreadyDefined <- liftIO $ isBound env "main"- let argv = List $ map String $ args- if alreadyDefined- then (runIOThrows $ liftM show $ evalLisp env- (List [Atom "main", List [Atom "quote", argv]])) >>= hPutStr stderr- else (runIOThrows $ liftM show $ evalLisp env (Nil "")) >>= hPutStr stderr--showBanner :: IO ()-showBanner = do- putStrLn " _ _ __ _ "- putStrLn " | | | | \\\\\\ | | "- putStrLn " | |__ _ _ ___| | __ \\\\\\ ___ ___| |__ ___ _ __ ___ ___ "- putStrLn " | '_ \\| | | / __| |/ / //\\\\\\ / __|/ __| '_ \\ / _ \\ '_ ` _ \\ / _ \\ "- putStrLn " | | | | |_| \\__ \\ < /// \\\\\\ \\__ \\ (__| | | | __/ | | | | | __/ "- putStrLn " |_| |_|\\__,_|___/_|\\_\\ /// \\\\\\ |___/\\___|_| |_|\\___|_| |_| |_|\\___| "- putStrLn " "- putStrLn " http://justinethier.github.com/husk-scheme "- putStrLn " (c) 2010-2012 Justin Ethier "- putStrLn " Version 3.5.1 "- putStrLn " "--runRepl :: IO ()-runRepl = do- stdlib <- getDataFileName "stdlib.scm"- env <- primitiveBindings- _ <- evalString env $ "(load \"" ++ stdlib ++ "\")" -- Load standard library into the REPL- runInputT defaultSettings (loop env)- where- loop :: Env -> InputT IO ()- loop env = do- minput <- getInputLine "huski> "- case minput of- Nothing -> return ()- Just "quit" -> return ()- Just "" -> loop env -- FUTURE: integrate with strip to ignore inputs of just whitespace- Just input -> do result <- liftIO (evalString env input)- if (length result) > 0- then do outputStrLn result- loop env- else loop env--- End REPL Section---- Begin Util section, of generic functions--{- Remove leading/trailing white space from a string; based on corresponding Python function- Code taken from: http://gimbo.org.uk/blog/2007/04/20/splitting-a-string-in-haskell/ -}-strip :: String -> String-strip s = dropWhile ws $ reverse $ dropWhile ws $ reverse s- where ws = (`elem` [' ', '\n', '\t', '\r'])---- End Util
husk-scheme.cabal view
@@ -1,6 +1,6 @@ Name: husk-scheme-Version: 3.5.1-Synopsis: R5RS Scheme interpreter program and library.+Version: 3.5.2+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, and the full numeric tower.@@ -9,7 +9,7 @@ Author: Justin Ethier Maintainer: Justin Ethier <github.com/justinethier> Homepage: http://justinethier.github.com/husk-scheme-Cabal-Version: >= 1.6+Cabal-Version: >= 1.8 Build-Type: Simple Category: Compilers/Interpreters, Language Tested-with: GHC == 7.2.2, GHC == 7.0.2, GHC == 6.12.3, GHC == 6.10.4@@ -29,8 +29,10 @@ Exposed-Modules: Language.Scheme.Core Language.Scheme.Types Language.Scheme.Variables+ Language.Scheme.Compiler Language.Scheme.Plugins.CPUTime- Other-Modules: Language.Scheme.FFI+-- Other-Modules:+ Language.Scheme.FFI Language.Scheme.Macro Language.Scheme.Macro.Matches Language.Scheme.Numerical@@ -38,16 +40,13 @@ Language.Scheme.Primitives Executable huski- Build-Depends: base >= 2.0 && < 5, array, containers, haskeline, transformers, mtl, parsec, directory, ghc, ghc-paths+ Build-Depends: husk-scheme, base >= 2.0 && < 5, array, containers, haskeline, transformers, mtl, parsec, directory, ghc, ghc-paths Extensions: ExistentialQuantification CPP CPP Main-is: shell.hs- Hs-Source-Dirs: hs-src- Other-Modules: Language.Scheme.Core- Language.Scheme.FFI- Language.Scheme.Types- Language.Scheme.Variables- Language.Scheme.Macro- Language.Scheme.Macro.Matches- Language.Scheme.Numerical- Language.Scheme.Parser- Language.Scheme.Primitives+ Hs-Source-Dirs: hs-src/Interpreter++Executable huskc+ Build-Depends: husk-scheme, base >= 2.0 && < 5, array, containers, haskeline, transformers, mtl, parsec, directory, ghc, ghc-paths, process, filepath, haskell98+ Extensions: ExistentialQuantification CPP CPP+ Main-is: huskc.hs+ Hs-Source-Dirs: hs-src/Compiler
stdlib.scm view
@@ -102,6 +102,11 @@ (define (length lst) (fold (lambda (x y) (+ y 1)) 0 lst)) (define (reverse lst) (fold (flip cons) '() lst)) +(define-syntax begin+ (syntax-rules ()+ ((begin exp ...)+ ((lambda () exp ...)))))+ ; cond ; Form from R5RS: (define-syntax cond