husk-scheme 3.5.5 → 3.5.6
raw patch · 9 files changed
+258/−117 lines, 9 files
Files
- README.markdown +1/−7
- hs-src/Compiler/huskc.hs +13/−1
- hs-src/Language/Scheme/Compiler.hs +122/−72
- hs-src/Language/Scheme/Core.hs +7/−16
- hs-src/Language/Scheme/Numerical.hs +5/−5
- hs-src/Language/Scheme/Parser.hs +39/−9
- hs-src/Language/Scheme/Primitives.hs +1/−1
- hs-src/Language/Scheme/Types.hs +52/−1
- husk-scheme.cabal +18/−5
README.markdown view
@@ -19,15 +19,9 @@ License -------+Copyright (C) 2010 [Justin Ethier](http://github.com/justinethier) husk scheme is available under the [MIT license](http://www.opensource.org/licenses/mit-license.php). -Credits----------husk scheme is developed by [Justin Ethier](http://github.com/justinethier).- 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.--For more information, please visit the [project web site](http://justinethier.github.com/husk-scheme).
hs-src/Compiler/huskc.hs view
@@ -150,13 +150,25 @@ -- |Compile a scheme file to haskell compileSchemeFile :: Env -> String -> String -> String -> IOThrowsError LispVal compileSchemeFile env stdlib srfi55 filename = do+ let conv :: LispVal -> String+ conv (String s) = s -- 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") libSrfi55C <- compileLisp env srfi55 "exec55" (Just "exec") _ <- liftIO $ registerSRFI env 1++ -- Initialize the compiler module and begin+ _ <- initializeCompiler env execC <- compileLisp env filename "exec" Nothing++ -- Append any additional import modules+ List imports <- getNamespacedVar env "internal" "imports"+ let moreHeaderImports = map conv imports+ outH <- liftIO $ openFile "_tmp.hs" WriteMode+ _ <- liftIO $ writeList outH headerModule+ _ <- liftIO $ writeList outH $ map (\mod -> "import " ++ mod ++ " ") $ headerImports ++ moreHeaderImports _ <- liftIO $ writeList outH header _ <- liftIO $ writeList outH $ map show libsC _ <- liftIO $ writeList outH $ map show libSrfi55C@@ -171,7 +183,7 @@ compileHaskellFile filename dynamic extraArgs = do let ghc = "ghc" -- Need to make configurable?? dynamicArg = if dynamic then "-dynamic" else ""- compileStatus <- system $ ghc ++ " " ++ dynamicArg ++ " " ++ extraArgs ++ " -cpp --make -package ghc -fglasgow-exts -o " ++ filename ++ " _tmp.hs"+ compileStatus <- system $ ghc ++ " " ++ dynamicArg ++ " " ++ extraArgs ++ " -cpp --make -package ghc -o " ++ filename ++ " _tmp.hs" -- TODO: delete intermediate hs files if requested
hs-src/Language/Scheme/Compiler.hs view
@@ -23,8 +23,8 @@ module Language.Scheme.Compiler where import qualified Language.Scheme.Macro-import Language.Scheme.Numerical-import Language.Scheme.Parser+-- import Language.Scheme.Numerical+-- import Language.Scheme.Parser import Language.Scheme.Primitives import Language.Scheme.Types import Language.Scheme.Variables@@ -32,9 +32,10 @@ import qualified Data.Array import Data.Complex import qualified Data.List+import qualified Data.Map import Data.Ratio-import System.IO-import Debug.Trace+-- 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@@ -49,14 +50,14 @@ defaultCompileOptions thisFunc = CompileOptions thisFunc False False Nothing createAstFunc :: CompOpts -> [HaskAST] -> HaskAST -createAstFunc (CompileOptions thisFunc useVal useArgs _) body = do+createAstFunc (CompileOptions thisFunc useVal useArgs _) funcBody = do let val = case useVal of True -> "value" _ -> "_" args = case useArgs of True -> "(Just args)" _ -> "_"- AstFunction thisFunc (" env cont " ++ val ++ " " ++ args ++ " ") body+ AstFunction thisFunc (" env cont " ++ val ++ " " ++ args ++ " ") funcBody createAstCont :: CompOpts -> String -> String -> HaskAST createAstCont (CompileOptions _ _ _ (Just nextFunc)) var indentation = do@@ -79,9 +80,9 @@ 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 + let fheader = "\n" ++ name ++ args ++ " = do "+ let fbody = unwords . map (\x -> "\n" ++ x ) $ map showValAST code+ fheader ++ fbody 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@@ -89,6 +90,7 @@ instance Show HaskAST where show = showValAST +joinL :: forall a. [[a]] -> [a] -> [a] joinL ls sep = concat $ Data.List.intersperse sep ls astToHaskellStr :: LispVal -> String @@ -101,6 +103,10 @@ astToHaskellStr (Float f) = "Float (" ++ show f ++ ")" astToHaskellStr (Bool True) = "Bool True" astToHaskellStr (Bool False) = "Bool False"+astToHaskellStr (HashTable ht) = do+ let ls = Data.Map.toList ht + conv (a, b) = "(" ++ astToHaskellStr a ++ "," ++ astToHaskellStr b ++ ")"+ "HashTable $ Data.Map.fromList $ [" ++ joinL (map conv ls) "," ++ "]" astToHaskellStr (Vector v) = do let ls = Data.Array.elems v size = (length ls) - 1@@ -109,44 +115,22 @@ astToHaskellStr (DottedList ls l) = "DottedList [" ++ joinL (map astToHaskellStr ls) "," ++ "] $ " ++ astToHaskellStr l -header :: [String]+header, headerModule, headerImports :: [String]+headerModule = ["module Main where "]+headerImports = [+ "Language.Scheme.Core "+ , "Language.Scheme.Numerical "+ , "Language.Scheme.Primitives "+ , "Language.Scheme.Types -- Scheme data types "+ , "Language.Scheme.Variables -- Scheme variable operations "+ , "Control.Monad.Error "+ , "Data.Array "+ , "Data.Complex "+ , " qualified Data.Map "+ , "Data.Ratio "+ , "System.IO "] header = [- "module Main where "- , "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 "@@ -159,6 +143,16 @@ -- NOTE: the following type is used for all functions generated by the compiler: -- , "run :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal " ++-- Define imports var here as an empty list.+-- This list is appended to by (load-ffi) instances,+-- and the imports are explicitly added later on...+initializeCompiler :: Env -> IOThrowsError [HaskAST]+initializeCompiler env = do+ _ <- defineNamespacedVar env "internal" "imports" $ List []+ return []++ compileLisp :: Env -> String -> String -> Maybe String -> IOThrowsError [HaskAST] compileLisp env filename entryPoint exitPoint = load filename >>= compileBlock entryPoint exitPoint env [] -- compileBlock@@ -166,10 +160,10 @@ -- 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+compileBlock symThisFunc symLastFunc env result [c] = do compiled <- mcompile env c $ CompileOptions symThisFunc False False symLastFunc return $ result ++ compiled-compileBlock symThisFunc symLastFunc env result code@(c:cs) = do+compileBlock symThisFunc symLastFunc env result (c:cs) = do Atom symNextFunc <- _gensym "f" compiled <- mcompile env c $ CompileOptions symThisFunc False False (Just symNextFunc) compileBlock symNextFunc symLastFunc env (result ++ compiled) cs@@ -189,7 +183,7 @@ 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"+ serialize a = throwError $ Default $ "invalid parameter to lambda list: " ++ show a compile :: Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST] compile _ (Nil n) copts = compileScalar (" return $ Nil " ++ (show n)) copts@@ -202,6 +196,7 @@ 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 _ ht@(HashTable _) copts = compileScalar (" return $ " ++ astToHaskellStr ht) copts compile _ (Atom a) copts = compileScalar (" getVar env \"" ++ a ++ "\"") copts compile _ (List [Atom "quote", val]) copts = compileScalar (" return $ " ++ astToHaskellStr val) copts@@ -213,12 +208,12 @@ -- compile _ (List [Atom "quasiquote", val]) copts = compileScalar (" return $ " ++ astToHaskellStr val) copts -compile env args@(List [Atom "expand", _body]) copts = do+compile env (List [Atom "expand", _body]) copts = do -- TODO: check if expand has been rebound? val <- Language.Scheme.Macro.expand env False _body compileScalar (" return $ " ++ astToHaskellStr val) copts -compile env args@(List (Atom "let-syntax" : List _bindings : _body)) copts = do+compile env (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@@ -228,7 +223,7 @@ 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+compile env (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@@ -238,7 +233,7 @@ 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+compile env (List [Atom "define-syntax", Atom keyword, (List (Atom "syntax-rules" : (List identifiers : rules)))]) copts = do -- -- TODO: --@@ -250,10 +245,10 @@ _ <- 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]) copts = compile env (List [Atom "if", predic, conseq, Nil ""]) copts -compile env args@(List [Atom "if", predic, conseq, alt]) copts@(CompileOptions thisFunc _ _ nextFunc) = do+compile env (List [Atom "if", predic, conseq, alt]) copts@(CompileOptions _ _ _ nextFunc) = do -- FUTURE: think about it, these could probably be part of compileExpr Atom symPredicate <- _gensym "ifPredic" Atom symCheckPredicate <- _gensym "compiledIfPredicate"@@ -277,7 +272,7 @@ -- 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+compile env (List [Atom "set!", Atom var, form]) copts@(CompileOptions _ _ _ _) = do Atom symDefine <- _gensym "setFunc" Atom symMakeDefine <- _gensym "setFuncMakeSet" @@ -294,14 +289,14 @@ createAstCont copts "result" ""] return $ [entryPt] ++ compDefine ++ [compMakeDefine] -compile env (List [Atom "set!", nonvar, _]) copts = do +compile _ (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+compile _ (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+compile env (List [Atom "define", Atom var, form]) copts@(CompileOptions _ _ _ _) = do Atom symDefine <- _gensym "defineFuncDefine" Atom symMakeDefine <- _gensym "defineFuncMakeDef" @@ -319,7 +314,7 @@ 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+compile env (List (Atom "define" : List (Atom var : fparams) : fbody)) copts@(CompileOptions _ _ _ _) = do Atom symCallfunc <- _gensym "defineFuncEntryPt" compiledParams <- compileLambdaList fparams compiledBody <- compileBlock symCallfunc Nothing env [] fbody@@ -338,7 +333,7 @@ ] return $ [createAstFunc copts f] ++ compiledBody -compile env args@(List (Atom "define" : DottedList (Atom var : fparams) varargs : fbody)) copts@(CompileOptions thisFunc _ _ nextFunc) = do+compile env (List (Atom "define" : DottedList (Atom var : fparams) varargs : fbody)) copts@(CompileOptions _ _ _ _) = do Atom symCallfunc <- _gensym "defineFuncEntryPt" compiledParams <- compileLambdaList fparams compiledBody <- compileBlock symCallfunc Nothing env [] fbody@@ -359,7 +354,7 @@ -compile env args@(List (Atom "lambda" : List fparams : fbody)) copts@(CompileOptions thisFunc _ _ nextFunc) = do+compile env (List (Atom "lambda" : List fparams : fbody)) copts@(CompileOptions _ _ _ _) = do Atom symCallfunc <- _gensym "lambdaFuncEntryPt" compiledParams <- compileLambdaList fparams @@ -379,7 +374,7 @@ ] return $ [createAstFunc copts f] ++ compiledBody -compile env args@(List (Atom "lambda" : DottedList fparams varargs : fbody)) copts@(CompileOptions thisFunc _ _ nextFunc) = do+compile env (List (Atom "lambda" : DottedList fparams varargs : fbody)) copts@(CompileOptions _ _ _ _) = do Atom symCallfunc <- _gensym "lambdaFuncEntryPt" compiledParams <- compileLambdaList fparams @@ -397,7 +392,7 @@ ] return $ [createAstFunc copts f] ++ compiledBody -compile env args@(List (Atom "lambda" : varargs@(Atom _) : fbody)) copts@(CompileOptions thisFunc _ _ nextFunc) = do+compile env (List (Atom "lambda" : varargs@(Atom _) : fbody)) copts@(CompileOptions _ _ _ _) = do Atom symCallfunc <- _gensym "lambdaFuncEntryPt" -- TODO: need to extend Env below when compiling body?@@ -413,7 +408,7 @@ createAstCont copts "result" " " ] return $ [createAstFunc copts f] ++ compiledBody-compile env args@(List [Atom "string-set!", Atom var, i, character]) copts = do+compile env (List [Atom "string-set!", Atom var, i, character]) copts = do Atom symDefine <- _gensym "stringSetFunc" Atom symMakeDefine <- _gensym "stringSetFuncMakeSet" @@ -431,7 +426,7 @@ -- TODO: eval env cont args@(List [Atom "string-set!" , nonvar , _ , _ ]) = do -- TODO: eval env cont fargs@(List (Atom "string-set!" : args)) = do -compile env args@(List [Atom "set-car!", Atom var, argObj]) copts = do+compile env (List [Atom "set-car!", Atom var, argObj]) copts = do Atom symGetVar <- _gensym "setCarGetVar" Atom symCompiledObj <- _gensym "setCarCompiledObj" Atom symObj <- _gensym "setCarObj"@@ -482,7 +477,7 @@ -- TODO: eval env cont args@(List [Atom "set-car!" , nonvar , _ ]) = do -- TODO: eval env cont fargs@(List (Atom "set-car!" : args)) = do -compile env args@(List [Atom "set-cdr!", Atom var, argObj]) copts = do+compile env (List [Atom "set-cdr!", Atom var, argObj]) copts = do Atom symGetVar <- _gensym "setCdrGetVar" Atom symCompiledObj <- _gensym "setCdrCompiledObj" Atom symObj <- _gensym "setCdrObj"@@ -532,7 +527,7 @@ -- TODO: eval env cont args@(List [Atom "set-cdr!" , nonvar , _ ]) = do -- TODO: eval env cont fargs@(List (Atom "set-cdr!" : args)) = do-compile env args@(List [Atom "vector-set!", Atom var, i, object]) copts = do+compile env (List [Atom "vector-set!", Atom var, i, object]) copts = do Atom symCompiledIdx <- _gensym "vectorSetIdx" Atom symCompiledObj <- _gensym "vectorSetObj" Atom symUpdateVec <- _gensym "vectorSetUpdate"@@ -556,14 +551,69 @@ -- 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+compile env (List [Atom "hash-table-set!", Atom var, rkey, rvalue]) copts = do+ Atom symCompiledIdx <- _gensym "hashTableSetIdx"+ Atom symCompiledObj <- _gensym "hashTableSetObj"+ Atom symUpdateVec <- _gensym "hashTableSetUpdate"+ Atom symIdxWrapper <- _gensym "hashTableSetIdxWrapper"++ -- Entry point that allows this form to be redefined+ entryPt <- compileSpecialFormEntryPoint "hash-table-set!" symCompiledIdx copts+ -- Compile index, then use a wrapper to pass it as an arg while compiling obj+ compiledIdx <- compileExpr env rkey symCompiledIdx (Just symIdxWrapper) + compiledIdxWrapper <- return $ AstFunction symIdxWrapper " env cont idx _ " [+ AstValue $ " " ++ symCompiledObj ++ " env (makeCPSWArgs env cont " ++ symUpdateVec ++ " [idx]) (Nil \"\") Nothing " ]+ compiledObj <- compileExpr env rvalue symCompiledObj Nothing+ -- Do actual update+ compiledUpdate <- return $ AstFunction symUpdateVec " env cont obj (Just [rkey]) " [+ -- TODO: this should be more robust, than just assuming ht is a HashTable+ AstValue $ " HashTable ht <- getVar env \"" ++ var ++ "\"",+ AstValue $ " result <- setVar env \"" ++ var ++ "\" (HashTable $ Data.Map.insert rkey obj ht) ",+ createAstCont copts "result" ""]++ return $ [entryPt, compiledIdxWrapper, compiledUpdate] ++ compiledIdx ++ compiledObj -- 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++compile env (List [Atom "hash-table-delete!", Atom var, rkey]) copts = do+ Atom symCompiledIdx <- _gensym "hashTableDeleteIdx"+ Atom symDoDelete <- _gensym "hashTableDelete"++ -- Entry point that allows this form to be redefined+ entryPt <- compileSpecialFormEntryPoint "hash-table-delete!" symCompiledIdx copts+ -- Compile index, then use a wrapper to pass it as an arg while compiling obj+ compiledIdx <- compileExpr env rkey symCompiledIdx (Just symDoDelete) + -- Do actual update+ compiledUpdate <- return $ AstFunction symDoDelete " env cont rkey _ " [+ -- TODO: this should be more robust, than just assuming ht is a HashTable+ AstValue $ " HashTable ht <- getVar env \"" ++ var ++ "\"",+ AstValue $ " result <- setVar env \"" ++ var ++ "\" (HashTable $ Data.Map.delete rkey ht) ",+ createAstCont copts "result" ""]++ return $ [entryPt, compiledUpdate] ++ compiledIdx -- TODO: eval env cont fargs@(List (Atom "hash-table-delete!" : args)) = do +-- FUTURE: eventually it should be possible to evaluate the args instead of assuming+-- that they are all strings, but lets keep it simple for now+compile env (List [Atom "load-ffi", + String moduleName, + String externalFuncName, + String internalFuncName]) copts = do+-- Atom symLoadFFI <- _gensym "loadFFI" + -- Only append module again if it is not already in the list+ List l <- getNamespacedVar env "internal" "imports"+ _ <- if not ((String moduleName) `elem` l)+ then setNamespacedVar env "internal" "imports" $ List $ l ++ [String moduleName]+ else return $ String "" + -- Pass along moduleName as another top-level import+ return [createAstFunc copts [+ AstValue $ " result <- defineVar env \"" ++ + internalFuncName ++ "\" $ IOFunc " ++ + moduleName ++ "." ++ externalFuncName,+ createAstCont copts "result" ""]]+ compile env args@(List (_ : _)) copts = mfunc env args compileApply copts compile _ badForm _ = throwError $ BadSpecialForm "Unrecognized special form" badForm @@ -606,7 +656,7 @@ -- |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+compileApply env (List (func : fparams)) (CompileOptions coptsThis _ _ coptsNext) = do Atom stubFunc <- _gensym "applyStubF" Atom wrapperFunc <- _gensym "applyWrapper" Atom nextFunc <- _gensym "applyNextF"@@ -615,7 +665,7 @@ -- 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+ rest <- compileArgs nextFunc False fparams -- False since no value passed in this time return $ [c, wrapper ] ++ _comp ++ rest where
hs-src/Language/Scheme/Core.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ {- | Module : Language.Scheme.Core Copyright : Justin Ethier@@ -27,7 +29,9 @@ , substr , updateVector ) where+#ifdef UseFfi import qualified Language.Scheme.FFI+#endif import qualified Language.Scheme.Macro import Language.Scheme.Numerical import Language.Scheme.Parser@@ -42,7 +46,7 @@ -- |husk version number version :: String-version = "3.5.5"+version = "3.5.6" -- |A utility function to display the husk console banner showBanner :: IO ()@@ -662,21 +666,6 @@ cpsEvalArgs _ _ _ Nothing = throwError $ Default "Unexpected error in function application (2)" prepareApply _ _ _ = throwError $ Default "Unexpected error in prepareApply" -makeFunc :: -- forall (m :: * -> *).- (Monad m) =>- Maybe String -> Env -> [LispVal] -> [LispVal] -> m LispVal-makeFunc varargs env fparams fbody = return $ Func (map showVal fparams) varargs fbody env-makeNormalFunc :: (Monad m) => Env- -> [LispVal]- -> [LispVal]- -> m LispVal-makeNormalFunc = makeFunc Nothing-makeVarargs :: (Monad m) => LispVal -> Env- -> [LispVal]- -> [LispVal]- -> m LispVal-makeVarargs = makeFunc . Just . showVal- -- |Call into a Scheme function apply :: LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal apply _ cont@(Continuation env ccont ncont _ ndynwind) args = do@@ -906,7 +895,9 @@ , ("eval", evalfuncEval) , ("load", evalfuncLoad) -- Non-standard extensions+#ifdef UseFfi , ("load-ffi", Language.Scheme.FFI.evalfuncLoadFFI)+#endif , ("exit-fail", evalfuncExitFail) , ("exit-success", evalfuncExitSuccess) ]
hs-src/Language/Scheme/Numerical.hs view
@@ -90,7 +90,7 @@ what numerical type they are passing when using these functions -} -numAdd, numSub, numMul, numDiv :: [LispVal] -> ThrowsError LispVal+numAdd, numSub, numMul, numDiv, numMod :: [LispVal] -> ThrowsError LispVal numAdd [] = return $ Number 0 numAdd aparams = do foldl1M (\ a b -> doAdd =<< (numCast [a, b])) aparams@@ -151,7 +151,7 @@ where doMod (List [(Number a), (Number b)]) = return $ Number $ mod' a b doMod (List [(Float a), (Float b)]) = return $ Float $ mod' a b doMod (List [(Rational a), (Rational b)]) = return $ Rational $ mod' a b- doMod (List [(Complex a), (Complex b)]) = throwError $ Default "modulo not implemented for complex numbers" + doMod (List [(Complex _), (Complex _)]) = throwError $ Default "modulo not implemented for complex numbers" doMod _ = throwError $ Default "Unexpected error in modulo" numBoolBinopEq :: [LispVal] -> ThrowsError LispVal@@ -406,7 +406,7 @@ numNumerator [x] = throwError $ TypeMismatch "rational number" x numNumerator badArgList = throwError $ NumArgs 1 badArgList -numDenominator [n@(Number _)] = return $ Number 1+numDenominator [Number _] = return $ Number 1 numDenominator [(Rational r)] = return $ Number $ denominator r numDenominator [(Float f)] = return $ Float $ fromInteger $ denominator $ toRational f numDenominator [x] = throwError $ TypeMismatch "rational number" x@@ -473,8 +473,8 @@ isInteger ([Complex n]) = do return $ Bool $ (isFloatAnInteger $ Float $ realPart n) && (isFloatAnInteger $ Float $ imagPart n) isInteger ([Rational n]) = do- let numer = numerator n- let denom = denominator n+ let numer = abs $ numerator n+ let denom = abs $ denominator n return $ Bool $ (numer >= denom) && ((mod numer denom) == 0) isInteger ([n@(Float _)]) = return $ Bool $ isFloatAnInteger n isInteger _ = return $ Bool False
hs-src/Language/Scheme/Parser.hs view
@@ -36,6 +36,7 @@ , parseEscapedChar , parseString , parseVector+ , parseHashTable , parseList , parseDottedList , parseQuoted@@ -45,14 +46,15 @@ ) where import Language.Scheme.Types import Control.Monad.Error+import Data.Array import qualified Data.Char as Char import Data.Complex-import Data.Array-import Numeric import Data.Ratio+import qualified Data.Map+import Numeric import Text.ParserCombinators.Parsec hiding (spaces) import Text.Parsec.Language-import Text.Parsec.Prim (ParsecT)+--import Text.Parsec.Prim (ParsecT) import qualified Text.Parsec.Token as P -- This was added by pull request #63 as part of a series of fixes@@ -208,19 +210,19 @@ -- in scientific notation. Eg "e10" from "1.0e10" parseNumberExponent :: LispVal -> Parser LispVal parseNumberExponent n = do - exp <- many $ oneOf "Ee"- case (length exp) of+ expnt <- many $ oneOf "Ee"+ case (length expnt) of 0 -> return n 1 -> do num <- try (parseDecimalNumber) case num of- Number exp -> buildResult n exp+ Number nexp -> buildResult n nexp _ -> pzero _ -> pzero where - buildResult (Number num) exp = return $ Float $ (fromIntegral num) * (10 ** (fromIntegral exp))- buildResult (Float num) exp = return $ Float $ num * (10 ** (fromIntegral exp))- buildResult num _ = pzero+ buildResult (Number num) nexp = return $ Float $ (fromIntegral num) * (10 ** (fromIntegral nexp))+ buildResult (Float num) nexp = return $ Float $ num * (10 ** (fromIntegral nexp))+ buildResult _ _ = pzero parseRationalNumber :: Parser LispVal parseRationalNumber = do@@ -280,6 +282,26 @@ vals <- sepBy parseExpr whiteSpace return $ Vector (listArray (0, (length vals - 1)) vals) +-- |Parse a hash table. The table is either empty or is made up of+-- an alist (associative list)+parseHashTable :: Parser LispVal+parseHashTable = do+ -- This function uses explicit recursion to loop over the parsed list:+ -- As long as it is an alist, the members are appended to an accumulator+ -- so they can be added to the hash table. However, if the input list is+ -- determined not to be an alist, Nothing is returned, letting the parser+ -- know that a valid hashtable was not read.+ let f :: [(LispVal, LispVal)] -> [LispVal] -> Maybe [(LispVal, LispVal)]+ f acc [] = Just acc+ f acc (List [a, b] :ls) = f (acc ++ [(a, b)]) ls+ f acc (DottedList [a] b :ls) = f (acc ++ [(a, b)]) ls+ f _ (_:_) = Nothing+ vals <- sepBy parseExpr whiteSpace+ let mvals = f [] vals+ case mvals of+ Just m -> return $ HashTable $ Data.Map.fromList m+ Nothing -> pzero+ parseList :: Parser LispVal parseList = liftM List $ sepBy parseExpr whiteSpace -- TODO: wanted to use endBy (or a variant) above, but it causes an error such that dotted lists are not parsed@@ -335,6 +357,10 @@ x <- parseExpr return $ List [Atom "unquote-splicing", x] +-- FUTURE: should be able to use the grammar from R5RS+-- to make parsing more efficient (mostly by minimizing+-- or eliminating the number of try's below)+ -- |Parse an expression parseExpr :: Parser LispVal parseExpr =@@ -346,6 +372,10 @@ <|> parseUnquoteSpliced <|> do _ <- try (lexeme $ string "#(") x <- parseVector+ _ <- lexeme $ char ')'+ return x+ <|> do _ <- try (lexeme $ string "#hash(")+ x <- parseHashTable _ <- lexeme $ char ')' return x <|> try (parseAtom)
hs-src/Language/Scheme/Primitives.hs view
@@ -101,7 +101,7 @@ import Language.Scheme.Numerical import Language.Scheme.Parser import Language.Scheme.Types-import qualified Control.Exception+--import qualified Control.Exception import Control.Monad.Error import Data.Char hiding (isSymbol) import Data.Array
hs-src/Language/Scheme/Types.hs view
@@ -314,7 +314,7 @@ if (show x) /= (show y) then return $ Bool False else eqvList eqv [List xBody, List yBody] -eqv [x@(HFunc _ _ xBody _), y@(Func _ _ yBody _)] = do+eqv [x@(HFunc _ _ _ _), y@(Func _ _ _ _)] = do if (show x) /= (show y) then return $ Bool False else return $ Bool True -- TODO: compare high-order functions... eqvList eqv [List xBody, List yBody] @@ -389,3 +389,54 @@ -- |Allow conversion of lispval instances to strings instance Show LispVal where show = showVal+++-- Functions required by the interpreter --++-- |Create a scheme function+makeFunc :: -- forall (m :: * -> *).+ (Monad m) =>+ Maybe String -> Env -> [LispVal] -> [LispVal] -> m LispVal+makeFunc varargs env fparams fbody = return $ Func (map showVal fparams) varargs fbody env++-- |Create a normal scheme function+makeNormalFunc :: (Monad m) => Env+ -> [LispVal]+ -> [LispVal]+ -> m LispVal+makeNormalFunc = makeFunc Nothing++-- |Create a scheme function that can receive any number of arguments+makeVarargs :: (Monad m) => LispVal -> Env+ -> [LispVal]+ -> [LispVal]+ -> m LispVal+makeVarargs = makeFunc . Just . showVal++-- Functions required by a compiled program --++-- |Create a haskell function+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+-- |Create a normal haskell function+makeNormalHFunc :: (Monad m) =>+ Env+ -> [String]+ -> (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)+ -> m LispVal+makeNormalHFunc = makeHFunc Nothing++-- |Create a haskell function that can receive any number of arguments+makeHVarargs :: (Monad m) => LispVal + -> Env+ -> [String]+ -> (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)+ -> m LispVal+makeHVarargs = makeHFunc . Just . showVal
husk-scheme.cabal view
@@ -1,5 +1,5 @@ Name: husk-scheme-Version: 3.5.5+Version: 3.5.6 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,@@ -23,8 +23,12 @@ Type: git Location: git://github.com/justinethier/husk-scheme.git +flag useffi+ description: Turn off FFI to decrease build times and minimize executable sizes+ default: True+ Library- Build-Depends: base >= 2.0 && < 5, array, containers, haskeline, transformers, mtl, parsec, directory, ghc, ghc-paths+ Build-Depends: base >= 2.0 && < 5, array, containers, haskeline, transformers, mtl, parsec, directory, ghc-paths Extensions: ExistentialQuantification Hs-Source-Dirs: hs-src Exposed-Modules: Language.Scheme.Core@@ -33,21 +37,30 @@ Language.Scheme.Compiler Language.Scheme.Plugins.CPUTime -- Other-Modules:- Language.Scheme.FFI Language.Scheme.Macro Language.Scheme.Macro.Matches Language.Scheme.Numerical Language.Scheme.Parser Language.Scheme.Primitives+ if flag(useffi)+ Build-Depends: ghc+ Exposed-Modules: Language.Scheme.FFI+ cpp-options: -DUseFfi Executable huski- Build-Depends: husk-scheme, 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-paths+ if flag(useffi)+ Build-Depends: ghc+ cpp-options: -DUseFfi Extensions: ExistentialQuantification Main-is: shell.hs 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+ Build-Depends: husk-scheme, base >= 2.0 && < 5, array, containers, haskeline, transformers, mtl, parsec, directory, ghc-paths, process, filepath+ if flag(useffi)+ Build-Depends: ghc+ cpp-options: -DUseFfi Extensions: ExistentialQuantification Main-is: huskc.hs Hs-Source-Dirs: hs-src/Compiler