diff --git a/ChangeLog.markdown b/ChangeLog.markdown --- a/ChangeLog.markdown +++ b/ChangeLog.markdown @@ -1,3 +1,19 @@ + +v3.11 +-------- + +The major change in this release is support for R7RS style library syntax in the compiler. This enables functionality that was previously only available in the interpreter, and sets the stage for husk to begin adding support for R7RS. + +API changes: + +- The Compiler Haskell API has been reorganized to use a Types module, and a new Libraries module has been added to store code for libraries. + +Bug fixes: + +- Allow the husk compiler to reference variables that are defined later in the program. For example, the following now compiles: `(define (foo) (bar))` `(define (bar) (foo))` +- Fixed `string-set!` to allow an expression to be passed as the character argument. +- Fixed `string-ref` to work when the string argument is passed using a variable. + v3.10 -------- diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,6 +1,6 @@ [husk-scheme](http://justinethier.github.com/husk-scheme) -husk is a dialect of Scheme written in Haskell that adheres to the [R5RS standard](http://www.schemers.org/Documents/Standards/R5RS/HTML/). Advanced R5RS features are provided including continuations, hygienic macros, and a full numeric tower. +husk is a dialect of Scheme written in Haskell that implements a superset of the [R5RS standard](http://www.schemers.org/Documents/Standards/R5RS/HTML/). Advanced R5RS features are provided including continuations, hygienic macros, and a full numeric tower. husk may be used as either a stand-alone interpreter or as an extension language within a larger Haskell application. By closely following the R5RS standard, the intent is to develop a Scheme that is as compatible as possible with other R5RS Schemes. husk is mature enough for use in production applications, however it is not optimized for performance-critical applications. diff --git a/hs-src/Compiler/huskc.hs b/hs-src/Compiler/huskc.hs --- a/hs-src/Compiler/huskc.hs +++ b/hs-src/Compiler/huskc.hs @@ -4,15 +4,15 @@ Licence : MIT (see LICENSE in the distribution) Maintainer : github.com/justinethier -Stability : experimental Portability : portable -A front-end for an experimental compiler +A front-end for the husk compiler -} module Main where import Paths_husk_scheme import Language.Scheme.Compiler +import Language.Scheme.Compiler.Types import qualified Language.Scheme.Core import Language.Scheme.Types -- Scheme data types import Language.Scheme.Variables -- Scheme variable operations @@ -27,13 +27,6 @@ main :: IO () main = do - putStrLn "" - putStrLn "!!! This version of huskc is Experimental !!!" - putStrLn "" - putStrLn "You might want to consult the issue list before 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 @@ -141,7 +134,7 @@ -- TODO: how to integrate r5rsEnv and libraries? - env <- Language.Scheme.Core.r5rsEnv + env <- Language.Scheme.Core.r5rsEnv' stdlib <- getDataFileName "lib/stdlib.scm" srfi55 <- getDataFileName "lib/srfi/srfi-55.scm" -- (require-extension) @@ -163,15 +156,19 @@ Just _ -> True _ -> False - (String nextFunc, libsC, libSrfi55C) <- case stdlib of - Nothing -> return (String "run", [], []) + -- TODO: clean this up later + --moduleFile <- liftIO $ getDataFileName "lib/modules.scm" + + (String nextFunc, libsC, libSrfi55C, libModules) <- case stdlib of + Nothing -> return (String "run", [], [], []) Just stdlib' -> do -- 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 "exec55_2") + libSrfi55C <- compileLisp env srfi55 "exec55" (Just "exec55_3") + --libModules <- compileLisp env moduleFile "exec55_2" (Just "exec55_3") liftIO $ Language.Scheme.Core.registerExtensions env getDataFileName - return (String "exec", libsC, libSrfi55C) + return (String "exec", libsC, libSrfi55C, []) --libModules) -- Initialize the compiler module and begin _ <- initializeCompiler env @@ -193,6 +190,8 @@ _ <- hPutStrLn outH " ------ END OF STDLIB ------" _ <- writeList outH $ map show libSrfi55C hPutStrLn outH " ------ END OF SRFI 55 ------" + -- _ <- writeList outH $ map show libModules + hPutStrLn outH " ------ END OF MODULES ------" False -> do hPutStrLn outH "exec _ _ _ _ = return $ Nil \"\"" -- Placeholder _ <- liftIO $ writeList outH $ map show execC diff --git a/hs-src/Language/Scheme/Compiler.hs b/hs-src/Language/Scheme/Compiler.hs --- a/hs-src/Language/Scheme/Compiler.hs +++ b/hs-src/Language/Scheme/Compiler.hs @@ -7,22 +7,53 @@ Stability : experimental Portability : portable -This module contains an experimental Scheme to Haskell compiler. - -The compiler performs the following transformations: +This module contains a Scheme to Haskell compiler which performs the following +transformations: > Scheme AST (LispVal) => Haskell AST (HaskAST) => Compiled Code (String) -The GHC compiler is then used to create a native executable. +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... -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... +Note the following type is used for all functions generated by the compiler: +> compiledFunc :: +> Env -> -- Runtime Environment +> LispVal -> -- Continuation +> LispVal -> -- Value +> Maybe [LispVal] -> -- Additional arguments +> IOThrowsError LispVal -- Result + -} -module Language.Scheme.Compiler where -import qualified Language.Scheme.Core (apply, evalLisp, version) +module Language.Scheme.Compiler + ( + compile + , compileApply + , compileBlock + , compileDivertedVars + , compileExpr + , compileLambdaList + , compileLisp + , compileScalar + , compileSpecialForm + , compileSpecialFormBody + , compileSpecialFormEntryPoint + , defineLambdaVars + , defineTopLevelVars + , divertVars + , initializeCompiler + , isPrim + , mcompile + , mfunc + ) +where +import Language.Scheme.Compiler.Libraries as LSCL +import Language.Scheme.Compiler.Types +import qualified Language.Scheme.Core as LSC + (apply, evalLisp, evalString, findFileOrLib, meval, nullEnvWithImport, + primitiveBindings, r5rsEnv, version) import qualified Language.Scheme.Macro import Language.Scheme.Primitives import Language.Scheme.Types @@ -38,176 +69,6 @@ import Data.Word -- 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 -> CompOpts -defaultCompileOptions thisFunc = CompileOptions thisFunc False False Nothing - --- |Create code for a function -createAstFunc - :: CompOpts -- ^ Compilation options - -> [HaskAST] -- ^ Body of the function - -> HaskAST -- ^ Complete function code -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 ++ " ") funcBody - --- |Create code for a continutation -createAstCont - :: CompOpts -- ^ Compilation options - -> String -- ^ Value to send to the continuation - -> String -- ^ Extra leading indentation (or blank string if none) - -> HaskAST -- ^ Generated code -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. --- FUTURE: is this even necessary? Would just a string be good enough? -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 fheader = "\n" ++ name ++ args ++ " = do " - let fbody = unwords . map (\x -> "\n" ++ x ) $ map showValAST code - fheader ++ fbody -showValAST (AstValue v) = v - -showValAST (AstContinuation nextFunc args) = - " continueEval env (makeCPSWArgs env cont " ++ - nextFunc ++ " " ++ args ++ ") $ Nil \"\"" - -instance Show HaskAST where show = showValAST - --- |A utility function to join list members together -joinL - :: forall a. [[a]] -- ^ Original list-of-lists - -> [a] -- ^ Separator - -> [a] -- ^ Joined list -joinL ls sep = concat $ Data.List.intersperse sep ls - --- |Convert abstract syntax tree to a string -ast2Str :: LispVal -> String -ast2Str (String s) = "String " ++ show s -ast2Str (Char c) = "Char " ++ show c -ast2Str (Atom a) = "Atom " ++ show a -ast2Str (Number n) = "Number (" ++ show n ++ ")" -ast2Str (Complex c) = "Complex $ (" ++ (show $ realPart c) ++ ") :+ (" ++ (show $ imagPart c) ++ ")" -ast2Str (Rational r) = "Rational $ (" ++ (show $ numerator r) ++ ") % (" ++ (show $ denominator r) ++ ")" -ast2Str (Float f) = "Float (" ++ show f ++ ")" -ast2Str (Bool True) = "Bool True" -ast2Str (Bool False) = "Bool False" -ast2Str (HashTable ht) = do - let ls = Data.Map.toList ht - conv (a, b) = "(" ++ ast2Str a ++ "," ++ ast2Str b ++ ")" - "HashTable $ Data.Map.fromList $ [" ++ joinL (map conv ls) "," ++ "]" -ast2Str (Vector v) = do - let ls = Data.Array.elems v - size = (length ls) - 1 - "Vector (listArray (0, " ++ show size ++ ")" ++ "[" ++ joinL (map ast2Str ls) "," ++ "])" -ast2Str (ByteVector bv) = do - let ls = BS.unpack bv - "ByteVector ( BS.pack " ++ "[" ++ joinL (map show ls) "," ++ "])" -ast2Str (List ls) = "List [" ++ joinL (map ast2Str ls) "," ++ "]" -ast2Str (DottedList ls l) = - "DottedList [" ++ joinL (map ast2Str ls) "," ++ "] $ " ++ ast2Str l - --- |Convert a list of abstract syntax trees to a list of strings -asts2Str :: [LispVal] -> String -asts2Str ls = do - "[" ++ (joinL (map ast2Str ls) ",") ++ "]" - -headerComment, headerModule, headerImports :: [String] -headerComment = [ - "--" - , "-- This file was automatically generated by the husk scheme compiler," - , "-- huskc version " ++ Language.Scheme.Core.version - , "--"] - -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 " - , " qualified Data.ByteString as BS " - , "Data.Complex " - , " qualified Data.Map " - , "Data.Ratio " - , "Data.Word " - , "System.IO "] - -header :: String -> Bool -> [String] -header filepath useCompiledLibs = do - let env = if useCompiledLibs - then "primitiveBindings" - else "r5rsEnv" - [ " " - , "-- |Get variable at runtime " - , "getRTVar env var = do " - , " v <- getVar env var " - , " return $ case v of " - , " List _ -> Pointer var env " - , " DottedList _ _ -> Pointer var env " - , " String _ -> Pointer var env " - , " Vector _ -> Pointer var env " - , " ByteVector _ -> Pointer var env " - , " HashTable _ -> Pointer var env " - , " _ -> v " - , " " - , "applyWrapper env cont (Nil _) (Just (a:as)) = do " - , " apply cont a as " - , " " - , "applyWrapper env cont value (Just (a:as)) = do " - , " apply cont a $ as ++ [value] " - , " " - , "getDataFileName' :: FilePath -> IO FilePath " - , "getDataFileName' name = return $ \"" ++ (Language.Scheme.Util.escapeBackslashes filepath) ++ "\" ++ name " - , " " - , "exec55_2 env cont _ _ = do " - , " liftIO $ registerExtensions env getDataFileName' " - , " continueEval env (makeCPS env cont exec) (Nil \"\")" - , " " - , "main :: IO () " - , "main = do " - , " env <- " ++ env ++ " " - , " result <- (runIOThrows $ liftM show $ run env (makeNullContinuation env) (Nil \"\") Nothing) " - , " case result of " - , " Just errMsg -> putStrLn errMsg " - , " _ -> return () " - , " "] - --- 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... @@ -218,20 +79,30 @@ compileLisp :: Env -> String -> String -> Maybe String -> IOThrowsError [HaskAST] -compileLisp env filename entryPoint exitPoint = load filename >>= compileBlock entryPoint exitPoint env [] +compileLisp env filename entryPoint exitPoint = do + filename' <- LSC.findFileOrLib filename + 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 [c] = do +compileBlock :: String -> Maybe String -> Env -> [HaskAST] -> [LispVal] + -> IOThrowsError [HaskAST] +compileBlock symThisFunc symLastFunc env result lisps = do + _ <- defineTopLevelVars env lisps + _compileBlock symThisFunc symLastFunc env result lisps + +_compileBlock :: String -> Maybe String -> Env -> [HaskAST] -> [LispVal] + -> IOThrowsError [HaskAST] +_compileBlock symThisFunc symLastFunc env result [c] = do compiled <- mcompile env c $ CompileOptions symThisFunc False False symLastFunc return $ result ++ compiled -compileBlock symThisFunc symLastFunc env result (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 -compileBlock _ _ _ result [] = return result + 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 @@ -247,17 +118,51 @@ serialized <- mapM serialize l return $ "[" ++ concat (Data.List.intersperse "," serialized) ++ "]" where serialize (Atom a) = return $ (show a) - serialize a = throwError $ Default $ "invalid parameter to lambda list: " ++ show a + serialize a = throwError $ Default $ + "invalid parameter to lambda list: " ++ show a -- |Add lambda variables to the compiler's environment defineLambdaVars :: Env -> [LispVal] -> IOThrowsError LispVal defineLambdaVars env (Atom v : vs) = do - _ <- defineVar env v $ Number 0 -- For now it is good enough to define it, actual value does not matter + _ <- defineVar env v $ Number 0 -- For now, actual value does not matter defineLambdaVars env vs defineLambdaVars env (_ : vs) = defineLambdaVars env vs defineLambdaVars env [] = return $ Nil "" +-- |Find all variables defined at "this" level and load their symbols into +-- the environment. This allows the compiler validation to work even +-- though a variable is used in a sub-form before it is defined further +-- on down in the program +defineTopLevelVars :: Env -> [LispVal] -> IOThrowsError LispVal +defineTopLevelVars env (List [Atom "define", Atom var, form] : ls) = do + _ <- defineTopLevelVar env var + defineTopLevelVars env ls +defineTopLevelVars env ((List (Atom "define" : List (Atom var : _) : _)) : ls) = do + _ <- defineTopLevelVar env var + defineTopLevelVars env ls +defineTopLevelVars env ((List (Atom "define" : DottedList (Atom var : _) _ : _)) : ls) = do + _ <- defineTopLevelVar env var + defineTopLevelVars env ls +defineTopLevelVars env (_ : ls) = defineTopLevelVars env ls +defineTopLevelVars _ _ = return nullLisp + +defineTopLevelVar env var = do + defineVar env var $ Number 0 -- Actual value not loaded at the moment + +-- |Compile a Lisp expression to Haskell. Note this function does +-- not expand macros; mcompile should be used instead if macros +-- may appear in the expression. compile :: Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST] +-- Experimenting with r7rs library support +compile env + ast@(List (Atom "import" : mods)) + copts@(CompileOptions thisFunc _ _ lastFunc) = do + LispEnv meta <- getVar env "*meta-env*" + LSCL.importAll env + meta + mods + (CompileLibraryOptions compileBlock compileLisp) + copts 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 @@ -278,11 +183,12 @@ createAstCont copts "val" ""] False -> throwError $ UnboundVar "Variable is not defined" a -compile _ (List [Atom "quote", val]) copts = compileScalar (" return $ " ++ ast2Str val) copts +compile _ (List [Atom "quote", val]) copts = + compileScalar (" return $ " ++ ast2Str val) copts compile env ast@(List [Atom "expand", _body]) copts = do compileSpecialFormBody env ast copts (\ _ -> do - val <- Language.Scheme.Macro.expand env False _body Language.Scheme.Core.apply + val <- Language.Scheme.Macro.expand env False _body LSC.apply compileScalar (" return $ " ++ ast2Str val) copts) compile env ast@(List (Atom "let-syntax" : List _bindings : _body)) copts = do @@ -290,7 +196,7 @@ 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) Language.Scheme.Core.apply + expanded <- Language.Scheme.Macro.expand bodyEnv False (List _body) LSC.apply divertVars bodyEnv expanded copts compexp) where -- Pick up execution here after expansion @@ -304,7 +210,7 @@ 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) Language.Scheme.Core.apply + expanded <- Language.Scheme.Macro.expand bodyEnv False (List _body) LSC.apply divertVars bodyEnv expanded copts compexp) where -- Pick up execution here after expansion @@ -313,6 +219,29 @@ List e -> compile bodyEnv' (List $ Atom "begin" : e) copts' e -> compile bodyEnv' e copts' +-- A non-standard way to rebind a macro to another keyword +compile env + ast@(List [Atom "define-syntax", + Atom newKeyword, + Atom keyword]) + copts = do + bound <- getNamespacedVar' env macroNamespace keyword + case bound of + Just m -> do + defineNamespacedVar env macroNamespace newKeyword m + compFunc <- return $ [ + AstValue $ " bound <- getNamespacedVar' env macroNamespace \"" ++ + keyword ++ "\"", + AstValue $ " case bound of ", + AstValue $ " Just m -> ", + AstValue $ " defineNamespacedVar env macroNamespace \"" ++ + newKeyword ++ "\" m", + AstValue $ " Nothing -> throwError $ TypeMismatch \"macro\" $ " ++ + "Atom \"" ++ keyword ++ "\"", + createAstCont copts "(Nil \"\")" ""] + return $ [createAstFunc copts compFunc] + Nothing -> throwError $ TypeMismatch "macro" $ Atom keyword + compile env ast@(List [Atom "define-syntax", Atom keyword, (List [Atom "er-macro-transformer", (List (Atom "lambda" : List fparams : fbody))])]) @@ -326,7 +255,8 @@ compFunc <- return $ [ AstValue $ " f <- makeNormalFunc env " ++ fparamsStr ++ " " ++ fbodyStr, - AstValue $ " defineNamespacedVar env macroNamespace \"" ++ keyword ++ "\" $ SyntaxExplicitRenaming f", + AstValue $ " defineNamespacedVar env macroNamespace \"" ++ keyword ++ + "\" $ SyntaxExplicitRenaming f", createAstCont copts "(Nil \"\")" ""] return $ [createAstFunc copts compFunc]) @@ -372,7 +302,8 @@ AstValue $ " _ -> " ++ symConsequence ++ " env cont (Nil \"\") [] "] -- Join compiled code together - return $ [createAstFunc copts f] ++ compPredicate ++ [compCheckPredicate] ++ compConsequence ++ compAlternate) + return $ [createAstFunc copts f] ++ compPredicate ++ [compCheckPredicate] ++ + compConsequence ++ compAlternate) compile env ast@(List [Atom "set!", Atom var, form]) copts@(CompileOptions _ _ _ _) = do compileSpecialFormBody env ast copts (\ nextFunc -> do @@ -380,14 +311,7 @@ Atom symMakeDefine <- _gensym "setFuncMakeSet" -- Store var in huskc's env for macro processing - -- - -- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -- TODO: this is going to cause problems for er macros - -- - -- 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) + _ <- setVar env var form entryPt <- compileSpecialFormEntryPoint "set!" symDefine copts compDefine <- compileExpr env form symDefine $ Just symMakeDefine @@ -398,11 +322,13 @@ compile env ast@(List [Atom "set!", nonvar, _]) copts = do compileSpecialFormBody env ast copts (\ nextFunc -> do - f <- compileSpecialForm "set!" ("throwError $ TypeMismatch \"variable\" $ String \"" ++ (show nonvar) ++ "\"") copts + f <- compileSpecialForm "set!" ("throwError $ TypeMismatch \"variable\"" ++ + " $ String \"" ++ (show nonvar) ++ "\"") copts return [f]) compile env ast@(List (Atom "set!" : args)) copts = do compileSpecialFormBody env ast copts (\ nextFunc -> do - f <- compileSpecialForm "set!" ("throwError $ NumArgs 2 $ [String \"" ++ (show args) ++ "\"]") copts -- TODO: Cheesy to use a string, but fine for now... + f <- compileSpecialForm "set!" ("throwError $ NumArgs 2 $ [String \"" ++ + (show args) ++ "\"]") copts -- Cheesy to use a string, but fine for now... return [f]) compile env ast@(List [Atom "define", Atom var, form]) copts@(CompileOptions _ _ _ _) = do @@ -432,7 +358,8 @@ createAstCont copts "result" ""] return $ [createAstFunc copts f] ++ compDefine ++ [compMakeDefine]) -compile env ast@(List (Atom "define" : List (Atom var : fparams) : fbody)) copts@(CompileOptions _ _ _ _) = do +compile env ast@(List (Atom "define" : List (Atom var : fparams) : fbody)) + copts@(CompileOptions _ _ _ _) = do compileSpecialFormBody env ast copts (\ nextFunc -> do bodyEnv <- liftIO $ extendEnv env [] -- bind lambda params in the extended env @@ -443,19 +370,22 @@ compiledBody <- compileBlock symCallfunc Nothing bodyEnv [] fbody -- Cache macro expansions within function body - ebody <- mapM (\ lisp -> Language.Scheme.Macro.macroEval env lisp Language.Scheme.Core.apply) fbody + ebody <- mapM (\ lisp -> Language.Scheme.Macro.macroEval env lisp LSC.apply) fbody -- Store var in huskc's env for macro processing (and same for other vers of define) _ <- makeNormalFunc env fparams ebody >>= defineVar env var -- Entry point; ensure var is not rebound f <- return $ [ - AstValue $ " result <- makeNormalHFunc env (" ++ compiledParams ++ ") " ++ symCallfunc, + AstValue $ " result <- makeNormalHFunc env (" ++ compiledParams ++ + ") " ++ symCallfunc, AstValue $ " _ <- defineVar env \"" ++ var ++ "\" result ", createAstCont copts "result" "" ] return $ [createAstFunc copts f] ++ compiledBody) -compile env ast@(List (Atom "define" : DottedList (Atom var : fparams) varargs : fbody)) copts@(CompileOptions _ _ _ _) = do +compile env + ast@(List (Atom "define" : DottedList (Atom var : fparams) varargs : fbody)) + copts@(CompileOptions _ _ _ _) = do compileSpecialFormBody env ast copts (\ nextFunc -> do bodyEnv <- liftIO $ extendEnv env [] -- bind lambda params in the extended env @@ -466,18 +396,19 @@ compiledBody <- compileBlock symCallfunc Nothing bodyEnv [] fbody -- Store var in huskc's env for macro processing (and same for other vers of define) - ebody <- mapM (\ lisp -> Language.Scheme.Macro.macroEval env lisp Language.Scheme.Core.apply) fbody + ebody <- mapM (\ lisp -> Language.Scheme.Macro.macroEval env lisp LSC.apply) fbody _ <- makeVarargs varargs env fparams ebody >>= defineVar env var -- Entry point; ensure var is not rebound f <- return $ [ - AstValue $ " result <- makeHVarargs (" ++ ast2Str varargs ++ ") env (" ++ compiledParams ++ ") " ++ symCallfunc, - AstValue $ " _ <- defineVar env \"" ++ var ++ "\" result ", - createAstCont copts "result" "" - ] + AstValue $ " result <- makeHVarargs (" ++ ast2Str varargs ++ ") env (" ++ + compiledParams ++ ") " ++ symCallfunc, + AstValue $ " _ <- defineVar env \"" ++ var ++ "\" result ", + createAstCont copts "result" "" ] return $ [createAstFunc copts f] ++ compiledBody) -compile env ast@(List (Atom "lambda" : List fparams : fbody)) copts@(CompileOptions _ _ _ _) = do +compile env ast@(List (Atom "lambda" : List fparams : fbody)) + copts@(CompileOptions _ _ _ _) = do compileSpecialFormBody env ast copts (\ nextFunc -> do Atom symCallfunc <- _gensym "lambdaFuncEntryPt" compiledParams <- compileLambdaList fparams @@ -489,15 +420,15 @@ compiledBody <- compileBlock symCallfunc Nothing bodyEnv [] 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 $ " result <- makeNormalHFunc env (" ++ compiledParams ++ ") " ++ symCallfunc, + AstValue $ " result <- makeNormalHFunc env (" ++ compiledParams ++ + ") " ++ symCallfunc, createAstCont copts "result" "" ] return $ [createAstFunc copts f] ++ compiledBody) -compile env ast@(List (Atom "lambda" : DottedList fparams varargs : fbody)) copts@(CompileOptions _ _ _ _) = do +compile env ast@(List (Atom "lambda" : DottedList fparams varargs : fbody)) + copts@(CompileOptions _ _ _ _) = do compileSpecialFormBody env ast copts (\ nextFunc -> do Atom symCallfunc <- _gensym "lambdaFuncEntryPt" compiledParams <- compileLambdaList fparams @@ -510,12 +441,13 @@ -- Entry point; ensure var is not rebound f <- return $ [ - AstValue $ " result <- makeHVarargs (" ++ ast2Str varargs ++ ") env (" ++ compiledParams ++ ") " ++ symCallfunc, - createAstCont copts "result" "" - ] + AstValue $ " result <- makeHVarargs (" ++ ast2Str varargs ++ ") env (" ++ + compiledParams ++ ") " ++ symCallfunc, + createAstCont copts "result" "" ] return $ [createAstFunc copts f] ++ compiledBody) -compile env ast@(List (Atom "lambda" : varargs@(Atom _) : fbody)) copts@(CompileOptions _ _ _ _) = do +compile env ast@(List (Atom "lambda" : varargs@(Atom _) : fbody)) + copts@(CompileOptions _ _ _ _) = do compileSpecialFormBody env ast copts (\ nextFunc -> do Atom symCallfunc <- _gensym "lambdaFuncEntryPt" @@ -536,21 +468,33 @@ compileSpecialFormBody env ast copts (\ nextFunc -> do Atom symDefine <- _gensym "stringSetFunc" Atom symMakeDefine <- _gensym "stringSetFuncMakeSet" + Atom symChr <- _gensym "stringSetChar" + Atom symCompiledI <- _gensym "stringI" - entryPt <- compileSpecialFormEntryPoint "string-set!" symDefine copts - compDefine <- compileExpr env i symDefine $ Just symMakeDefine - compMakeDefine <- return $ AstFunction symMakeDefine " env cont idx _ " [ + entryPt <- compileSpecialFormEntryPoint "string-set!" symChr copts + compChr <- compileExpr env character symChr $ Just symDefine + compDefine <- return $ AstFunction symDefine " env cont chr _ " [ + AstValue $ " " ++ symCompiledI ++ " env (makeCPSWArgs env cont " ++ + symMakeDefine ++ " [chr]) (Nil \"\") Nothing " ] + compI <- compileExpr env i symCompiledI Nothing + compMakeDefine <- return $ AstFunction symMakeDefine " env cont idx (Just [chr]) " [ AstValue $ " tmp <- getVar env \"" ++ var ++ "\"", AstValue $ " derefValue <- recDerefPtrs tmp", - -- TODO: not entirely correct below; should compile the character argument rather - -- than directly inserting it into the compiled code... - AstValue $ " result <- substr (derefValue, (" ++ ast2Str(character) ++ "), idx)", + AstValue $ " result <- substr (derefValue, chr, idx)", AstValue $ " _ <- updateObject env \"" ++ var ++ "\" result", createAstCont copts "result" ""] - return $ [entryPt] ++ compDefine ++ [compMakeDefine]) + return $ [entryPt, compDefine, compMakeDefine] ++ compI ++ compChr) --- TODO: eval env cont args@(List [Atom "string-set!" , nonvar , _ , _ ]) = do --- TODO: eval env cont fargs@(List (Atom "string-set!" : args)) = do +compile env ast@(List [Atom "string-set!", nonvar, _, _]) copts = do + compileSpecialFormBody env ast copts (\ nextFunc -> do + f <- compileSpecialForm "string-set!" ("throwError $ TypeMismatch \"variable\"" ++ + " $ String \"" ++ (show nonvar) ++ "\"") copts + return [f]) +compile env ast@(List (Atom "string-set!" : args)) copts = do + compileSpecialFormBody env ast copts (\ nextFunc -> do + f <- compileSpecialForm "string-set!" ("throwError $ NumArgs 3 $ [String \"" ++ + (show args) ++ "\"]") copts + return [f]) compile env ast@(List [Atom "set-car!", Atom var, argObj]) copts = do compileSpecialFormBody env ast copts (\ nextFunc -> do @@ -576,22 +520,23 @@ -- 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 + -- 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. + -- 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" + symObj ++ " :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal\n" ++ + symObj ++ " _ _ obj@(List []) _ = throwError $ TypeMismatch \"pair\" obj\n" ++ + 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. + -- 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" ++ @@ -602,8 +547,16 @@ -- 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 +compile env ast@(List [Atom "set-car!", nonvar, _]) copts = do + compileSpecialFormBody env ast copts (\ nextFunc -> do + f <- compileSpecialForm "set-car!" ("throwError $ TypeMismatch \"variable\"" ++ + " $ String \"" ++ (show nonvar) ++ "\"") copts + return [f]) +compile env ast@(List (Atom "set-car!" : args)) copts = do + compileSpecialFormBody env ast copts (\ nextFunc -> do + f <- compileSpecialForm "set-car!" ("throwError $ NumArgs 2 $ [String \"" ++ + (show args) ++ "\"]") copts + return [f]) compile env ast@(List [Atom "set-cdr!", Atom var, argObj]) copts = do compileSpecialFormBody env ast copts (\ nextFunc -> do @@ -634,35 +587,46 @@ -- 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" + 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" + 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. + -- 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 : _)]) = do\n" ++ - " l' <- recDerefPtrs l\n" ++ - " obj' <- recDerefPtrs obj\n" ++ - " (cons [l', obj']) >>= updateObject e \"" ++ var ++ "\" >>= " ++ finalContinuation ++ - symDoSet ++ " e c obj (Just [DottedList (l : _) _]) = do\n" ++ - " l' <- recDerefPtrs l\n" ++ - " obj' <- recDerefPtrs obj\n" ++ - " (cons [l', obj']) >>= updateObject e \"" ++ var ++ "\" >>= " ++ finalContinuation ++ - symDoSet ++ " _ _ _ _ = throwError $ InternalError \"Unexpected argument to " ++ symDoSet ++ "\"\n" + symDoSet ++ " :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal\n" ++ + symDoSet ++ " e c obj (Just [List (l : _)]) = do\n" ++ + " l' <- recDerefPtrs l\n" ++ + " obj' <- recDerefPtrs obj\n" ++ + " (cons [l', obj']) >>= updateObject e \"" ++ var ++ "\" >>= " ++ finalContinuation ++ + symDoSet ++ " e c obj (Just [DottedList (l : _) _]) = do\n" ++ + " l' <- recDerefPtrs l\n" ++ + " obj' <- recDerefPtrs obj\n" ++ + " (cons [l', obj']) >>= updateObject e \"" ++ var ++ "\" >>= " ++ 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 +compile env ast@(List [Atom "set-cdr!", nonvar, _]) copts = do + compileSpecialFormBody env ast copts (\ nextFunc -> do + f <- compileSpecialForm "set-cdr!" ("throwError $ TypeMismatch \"variable\"" ++ + " $ String \"" ++ (show nonvar) ++ "\"") copts + return [f]) +compile env ast@(List (Atom "set-cdr!" : args)) copts = do + compileSpecialFormBody env ast copts (\ nextFunc -> do + f <- compileSpecialForm "set-cdr!" ("throwError $ NumArgs 2 $ [String \"" ++ + (show args) ++ "\"]") copts + return [f]) + compile env ast@(List [Atom "vector-set!", Atom var, i, object]) copts = do compileSpecialFormBody env ast copts (\ nextFunc -> do Atom symCompiledIdx <- _gensym "vectorSetIdx" @@ -685,9 +649,18 @@ 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 +compile env ast@(List [Atom "vector-set!", nonvar, _, _]) copts = do + compileSpecialFormBody env ast copts (\ nextFunc -> do + f <- compileSpecialForm "vector-set!" ("throwError $ TypeMismatch \"variable\"" ++ + " $ String \"" ++ (show nonvar) ++ "\"") copts + return [f]) +compile env ast@(List (Atom "vector-set!" : args)) copts = do + compileSpecialFormBody env ast copts (\ nextFunc -> do + f <- compileSpecialForm "vector-set!" ("throwError $ NumArgs 3 $ [String \"" ++ + (show args) ++ "\"]") copts + return [f]) + compile env ast@(List [Atom "bytevector-u8-set!", Atom var, i, object]) copts = do compileSpecialFormBody env ast copts (\ nextFunc -> do Atom symCompiledIdx <- _gensym "bytevectorSetIdx" @@ -710,8 +683,16 @@ return $ [entryPt, compiledIdxWrapper, compiledUpdate] ++ compiledIdx ++ compiledObj) --- TODO: eval env cont args@(List [Atom "bytevector-u8-set!" , nonvar , _ , _]) = do --- TODO: eval env cont fargs@(List (Atom "bytevector-u8-set!" : args)) = do +compile env ast@(List [Atom "bytevector-u8-set!", nonvar, _, _]) copts = do + compileSpecialFormBody env ast copts (\ nextFunc -> do + f <- compileSpecialForm "bytevector-u8-set!" ("throwError $ TypeMismatch \"variable\"" ++ + " $ String \"" ++ (show nonvar) ++ "\"") copts + return [f]) +compile env ast@(List (Atom "bytevector-u8-set!" : args)) copts = do + compileSpecialFormBody env ast copts (\ nextFunc -> do + f <- compileSpecialForm "bytevector-u8-set!" ("throwError $ NumArgs 3 $ [String \"" ++ + (show args) ++ "\"]") copts + return [f]) compile env ast@(List [Atom "hash-table-set!", Atom var, rkey, rvalue]) copts = do compileSpecialFormBody env ast copts (\ nextFunc -> do @@ -737,8 +718,16 @@ 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 +compile env ast@(List [Atom "hash-table-set!", nonvar, _, _]) copts = do + compileSpecialFormBody env ast copts (\ nextFunc -> do + f <- compileSpecialForm "hash-table-set!" ("throwError $ TypeMismatch \"variable\"" ++ + " $ String \"" ++ (show nonvar) ++ "\"") copts + return [f]) +compile env ast@(List (Atom "hash-table-set!" : args)) copts = do + compileSpecialFormBody env ast copts (\ nextFunc -> do + f <- compileSpecialForm "hash-table-set!" ("throwError $ NumArgs 3 $ [String \"" ++ + (show args) ++ "\"]") copts + return [f]) compile env ast@(List [Atom "hash-table-delete!", Atom var, rkey]) copts = do compileSpecialFormBody env ast copts (\ nextFunc -> do @@ -758,8 +747,18 @@ createAstCont copts "result" ""] return $ [entryPt, compiledUpdate] ++ compiledIdx) --- TODO: eval env cont fargs@(List (Atom "hash-table-delete!" : args)) = do +compile env ast@(List [Atom "hash-table-delete!", nonvar, _]) copts = do + compileSpecialFormBody env ast copts (\ nextFunc -> do + f <- compileSpecialForm "hash-table-delete!" ("throwError $ TypeMismatch \"variable\"" ++ + " $ String \"" ++ (show nonvar) ++ "\"") copts + return [f]) +compile env ast@(List (Atom "hash-table-delete!" : args)) copts = do + compileSpecialFormBody env ast copts (\ nextFunc -> do + f <- compileSpecialForm "hash-table-delete!" ("throwError $ NumArgs 2 $ [String \"" ++ + (show args) ++ "\"]") copts + return [f]) + compile env ast@(List (Atom "%import" : args)) copts = do compileSpecialFormBody env ast copts (\ nextFunc -> do throwError $ NotImplemented $ "%import, with args: " ++ show args) @@ -771,8 +770,7 @@ -- Explicitly do NOT call compileSpecialFormBody here, since load is not normally a special form -- F*ck it, just run the evaluator here since filename is req'd at compile time - --String filename' <- Language.Scheme.Core.evalLisp env filename - fname <- Language.Scheme.Core.evalLisp env filename + fname <- LSC.evalLisp env filename case fname of -- Compile contents of the file String fn -> compileFile fn @@ -812,12 +810,13 @@ compile env (List [Atom "load", filename]) copts = do -- TODO: allow filename from a var, support env optional arg -- TODO: error handling for string below - String filename' <- Language.Scheme.Core.evalLisp env filename + String filename' <- LSC.evalLisp env filename Atom symEntryPt <- _gensym "load" result <- compileLisp env filename' symEntryPt Nothing return $ result ++ [createAstFunc copts [ - AstValue $ " result <- " ++ symEntryPt ++ " env (makeNullContinuation env) (Nil \"\") Nothing", + AstValue $ " result <- " ++ symEntryPt ++ + " env (makeNullContinuation env) (Nil \"\") Nothing", createAstCont copts "result" ""]] -- FUTURE: eventually it should be possible to evaluate the args instead of assuming @@ -831,7 +830,8 @@ -- Only append module again if it is not already in the list List l <- getNamespacedVar env 't' {-"internal"-} "imports" _ <- if not ((String moduleName) `elem` l) - then setNamespacedVar env 't' {-"internal"-} "imports" $ List $ l ++ [String moduleName] + then setNamespacedVar env 't' {-"internal"-} "imports" $ + List $ l ++ [String moduleName] else return $ String "" -- Pass along moduleName as another top-level import @@ -844,11 +844,18 @@ compile env args@(List (_ : _)) copts = mfunc env args compileApply copts compile _ badForm _ = throwError $ BadSpecialForm "Unrecognized special form" badForm +-- |Expand macros and compile the resulting code 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] + +-- |Expand macros and then pass control to the given function +mfunc :: Env + -> LispVal + -> (Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]) + -> CompOpts + -> IOThrowsError [HaskAST] mfunc env lisp func copts = do - expanded <- Language.Scheme.Macro.macroEval env lisp Language.Scheme.Core.apply + expanded <- Language.Scheme.Macro.macroEval env lisp LSC.apply divertVars env expanded copts func -- |Do the actual insertion of diverted variables back to the @@ -907,7 +914,10 @@ -- |A wrapper for each special form that allows the form variable -- (EG: "if") to be redefined at compile time -compileSpecialFormBody env ast@(List (Atom fnc : args)) copts@(CompileOptions _ _ _ nextFunc) spForm = do +compileSpecialFormBody env + ast@(List (Atom fnc : args)) + copts@(CompileOptions _ _ _ nextFunc) + spForm = do isDefined <- liftIO $ isRecBound env fnc case isDefined of True -> mfunc env ast compileApply copts @@ -935,7 +945,7 @@ -- Primitive (non-I/O) function with literal args, -- evaluate at compile time (Just primFunc, Just ls, _) -> do - result <- Language.Scheme.Core.apply + result <- LSC.apply (makeNullContinuation env) primFunc ls @@ -982,7 +992,8 @@ c <- return $ AstFunction coptsThis " env cont _ _ " [ - AstValue $ " continueEval env (makeCPS env (makeCPS env cont " ++ nextFunc ++ ") " ++ stubFunc ++ ") $ Nil\"\""] + AstValue $ " continueEval env (makeCPS env (makeCPS env cont " ++ + nextFunc ++ ") " ++ stubFunc ++ ") $ Nil\"\""] _comp <- mcompile env func $ CompileOptions stubFunc False False Nothing -- Haskell variables must be used to retrieve each atom from the env @@ -994,10 +1005,13 @@ rest <- case coptsNext of Nothing -> return $ [ AstFunction nextFunc - " env cont value _ " $ varLines ++ [AstValue $ " apply cont value " ++ args]] + " env cont value _ " $ varLines ++ + [AstValue $ " apply cont value " ++ args]] Just fnextExpr -> return $ [ AstFunction nextFunc - " env cont value _ " $ varLines ++ [AstValue $ " apply (makeCPS env cont " ++ fnextExpr ++ ") value " ++ args]] + " env cont value _ " $ varLines ++ + [AstValue $ " apply (makeCPS env cont " ++ + fnextExpr ++ ") value " ++ args]] return $ [c] ++ _comp ++ rest -- |Compile function and args as a chain of continuations @@ -1008,11 +1022,13 @@ c <- return $ AstFunction coptsThis " env cont _ _ " [ - AstValue $ " continueEval env (makeCPS env (makeCPS env cont " ++ wrapperFunc ++ ") " ++ stubFunc ++ ") $ Nil\"\""] + 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 \"\""] + AstValue $ " continueEval env (makeCPSWArgs env cont " ++ + nextFunc ++ " [value]) $ Nil \"\""] _comp <- mcompile env func $ CompileOptions stubFunc False False Nothing rest <- case fparams of diff --git a/hs-src/Language/Scheme/Compiler/Libraries.hs b/hs-src/Language/Scheme/Compiler/Libraries.hs new file mode 100644 --- /dev/null +++ b/hs-src/Language/Scheme/Compiler/Libraries.hs @@ -0,0 +1,329 @@ +{- | +Module : Language.Scheme.Compiler.Libraries +Copyright : Justin Ethier +Licence : MIT (see LICENSE in the distribution) + +Maintainer : github.com/justinethier +Stability : experimental +Portability : portable + +This module contains support for compiling libraries of scheme code. + +-} + +module Language.Scheme.Compiler.Libraries + ( + importAll + ) +where +import Language.Scheme.Compiler.Types +import qualified Language.Scheme.Core as LSC + (evalLisp, findFileOrLib, meval, nullEnvWithImport) +import Language.Scheme.Primitives +import Language.Scheme.Types +import Language.Scheme.Variables +import Control.Monad.Error + +-- |Import all given modules and generate code for them +importAll + :: Env + -- ^ Compilation environment + -> Env + -- ^ Compilation meta environment, containing code from modules.scm + -> [LispVal] + -- ^ Modules to import + -> CompLibOpts + -- ^ Misc options required by compiler library functions + -> CompOpts + -- ^ Misc options required by compiler functions + -> IOThrowsError [HaskAST] + -- ^ Compiled code +importAll env metaEnv [m] lopts + copts@(CompileOptions thisFunc _ _ lastFunc) = do + _importAll env metaEnv m lopts copts +importAll env metaEnv (m : ms) lopts + copts@(CompileOptions thisFunc _ _ lastFunc) = do + Atom nextFunc <- _gensym "importAll" + c <- _importAll env metaEnv m lopts $ + CompileOptions thisFunc False False (Just nextFunc) + rest <- importAll env metaEnv ms lopts $ + CompileOptions nextFunc False False lastFunc + stub <- case rest of + [] -> return [createFunctionStub nextFunc lastFunc] + _ -> return [] + return $ c ++ rest ++ stub +importAll _ _ [] _ _ = return [] + +_importAll env metaEnv m lopts copts = do + -- Resolve import + resolved <- LSC.evalLisp metaEnv $ + List [Atom "resolve-import", List [Atom "quote", m]] + case resolved of + List (moduleName : imports) -> do + importModule env metaEnv moduleName imports lopts copts + DottedList [List moduleName] imports@(Bool False) -> do + importModule env metaEnv (List moduleName) [imports] lopts copts + err -> throwError $ TypeMismatch "module/import" err + +-- |Import a single module +importModule env metaEnv moduleName imports lopts + copts@(CompileOptions thisFunc _ _ lastFunc) = do + Atom symImport <- _gensym "importFnc" + + -- Load module + code <- loadModule metaEnv moduleName lopts $ + CompileOptions thisFunc False False (Just symImport) + + -- Get module env, and import module env into env + LispEnv modEnv <- LSC.evalLisp metaEnv $ + List [Atom "module-env", List [Atom "find-module", List [Atom "quote", moduleName]]] + _ <- eval env $ List [Atom "%import", + LispEnv env, + LispEnv modEnv, + List [Atom "quote", List imports], + Bool False] + + importFunc <- return $ [ + -- fromEnv is a LispEnv passed in as the 'value' parameter. + -- But the source of 'value' is different depending on the + -- context, so we call into this function to figure it out + codeToGetFromEnv moduleName code, + AstValue $ " _ <- evalLisp env $ List [Atom \"%import\", LispEnv env, value, List [Atom \"quote\", " ++ + (ast2Str $ List imports) ++ "], Bool False]", + createAstCont (CompileOptions symImport False False lastFunc) "(value)" ""] + + -- thisFunc MUST be defined, so include a stub if there was nothing to import + stub <- case code of + [] -> return [createFunctionStub thisFunc (Just symImport)] + _ -> return [] + + return $ [createAstFunc (CompileOptions symImport True False lastFunc) + importFunc] ++ code ++ stub + where + -- + -- The import's "from" env can come from many places; this function + -- figures that out and creates a new 'value' if necessary to send + -- the proper value to %import in the above code + -- + codeToGetFromEnv (List [Atom "scheme", Atom "r5rs"]) _ = do + -- This is a hack to compile-in a full environment for the (scheme r5rs) import. + -- + -- TODO: This really should be handled by the add-module! that is executed during + -- module initialization, instead of having a special case here + AstValue $ " r5 <- liftIO $ r5rsEnv\n let value = LispEnv r5" + + codeToGetFromEnv name [] = do + -- No code was generated because module was loaded previously, so retrieve + -- it from runtime memory + AstValue $ " value <- evalLisp env $ List [Atom \"hash-table-ref\", Atom \"" ++ + moduleRuntimeVar ++ "\", List [Atom \"quote\", " ++ + (ast2Str name) ++ "]]" + + codeToGetFromEnv _ _ = AstValue $ "" + +-- | Load module into memory and generate compiled code +loadModule + :: Env + -- ^ Compilation meta environment, containing code from modules.scm + -> LispVal + -- ^ Name of the module to load + -> CompLibOpts + -- ^ Misc options required by compiler library functions + -> CompOpts + -- ^ Misc options required by compiler functions + -> IOThrowsError [HaskAST] + -- ^ Compiled code, or an empty list if the module was already compiled + -- and loaded into memory +loadModule metaEnv name lopts copts@(CompileOptions thisFunc _ _ lastFunc) = do + -- Get the module definition, or load it from file if necessary + mod' <- eval metaEnv $ List [Atom "find-module", List [Atom "quote", name]] + case mod' of + Bool False -> return [] -- Even possible to reach this line? + _ -> do + mod <- recDerefPtrs mod' + modEnv <- LSC.evalLisp metaEnv $ List [Atom "module-env", mod] + case modEnv of + Bool False -> do + {------------------------------------------- + Control flow for compiled code: + + - create new env + - call into func directly to load it + - return new env and save to memory + - continue on to lastFunc + --------------------------------------------} + Atom symStartLoadNewEnv <- _gensym "startLoadingNewEnvFnc" + Atom symEndLoadNewEnv <- _gensym "doneLoadingNewEnvFnc" + + newEnvFunc <- return $ [ + AstValue $ " newEnv <- liftIO $ nullEnvWithImport", + AstValue $ " _ <- defineVar newEnv \"" ++ moduleRuntimeVar ++ + "\" $ Pointer \"" ++ moduleRuntimeVar ++ "\" env", + AstValue $ " _ <- " ++ symStartLoadNewEnv ++ + " newEnv (makeNullContinuation newEnv) (LispEnv env) []", + -- Save loaded module into runtime memory in case + -- it gets included somewhere else later on + AstValue $ " _ <- evalLisp env $ List [Atom \"hash-table-set!\", Atom \"" ++ + moduleRuntimeVar ++ "\", List [Atom \"quote\", " ++ + (ast2Str name) ++ "], LispEnv newEnv]", + createAstCont copts "(LispEnv newEnv)" ""] + + -- Create new env for module, per eval-module + newEnv <- liftIO $ LSC.nullEnvWithImport + -- compile the module code, again per eval-module + result <- compileModule newEnv metaEnv name mod lopts $ + CompileOptions symStartLoadNewEnv False False (Just symEndLoadNewEnv) + modWEnv <- eval metaEnv $ List (Atom "module-env-set!" : mod' : [LispEnv newEnv]) + -- Above does not update *modules* correctly, so we del/add below + _ <- eval metaEnv $ List [Atom "delete-module!", List [Atom "quote", name]] + _ <- eval metaEnv $ List [Atom "add-module!", List [Atom "quote", name], modWEnv] + + return $ + [createAstFunc copts newEnvFunc] ++ + [createAstFunc (CompileOptions symEndLoadNewEnv False False Nothing) + [AstValue " return $ Nil \"\""]] ++ + result + _ -> return [] --mod + +-- |Compile the given module, using metadata loaded into memory. +-- This code is based off of eval-module from the meta language. +compileModule env metaEnv name mod lopts + copts@(CompileOptions thisFunc _ _ lastFunc) = do + -- TODO: set mod meta-data to avoid cyclic references + -- see modules.scm for how this is done by the interpreter + Atom afterImportsFnc <- _gensym "modAfterImport" + Atom afterDirFunc <- _gensym "modAfterDir" + + metaData <- LSC.evalLisp metaEnv $ + List [Atom "module-meta-data", List [Atom "quote", mod]] + + moduleImports <- cmpSubMod env metaEnv metaData lopts $ + CompileOptions thisFunc False False (Just afterImportsFnc) + moduleDirectives <- cmpModExpr env metaEnv name metaData lopts $ + moduleDirsCopts moduleImports afterImportsFnc + + return $ moduleImports ++ + moduleDirectives ++ + (moduleStub moduleImports moduleDirectives afterImportsFnc) + where + moduleDirsCopts modImps afterImportsFnc = do +-- if moduleImports is [] then use same copts for moduleDir +-- else, use copts (afterImportsFunc, lastFunc) + case modImps of + [] -> CompileOptions thisFunc False False (Just afterImportsFnc) + _ -> CompileOptions afterImportsFnc False False lastFunc + moduleStub modImps modDir afterImportsFnc = do +-- if moduleDir == [] and moduleimports == [] then add stub (this, last) +-- else if modDir == [] then addstub (afterimports, last) +-- else, no stub required + case (modImps, modDir) of + ([], []) -> [createFunctionStub thisFunc lastFunc] + ([], _) -> [createFunctionStub afterImportsFnc lastFunc] + (_, []) -> [createFunctionStub afterImportsFnc lastFunc] + _ -> [] -- Both have code, no stub needed + +-- Helper function to create an empty continuation +-- +-- TODO: ideally stubs would not be necessary, +-- should refactor out at some point +--createFunctionStub :: String -> HaskAST +createFunctionStub thisFunc nextFunc = do + createAstFunc (CompileOptions thisFunc True False Nothing) + [createAstCont (CompileOptions "" True False nextFunc) + "value" ""] + +-- |Compile sub-modules. That is, modules that are imported by +-- another module in the (define-library) definition +cmpSubMod env metaEnv (List ((List (Atom "import-immutable" : modules)) : ls)) + lopts copts = do + -- Punt on this for now, although the meta-lang does the same thing + cmpSubMod env metaEnv + (List ((List (Atom "import" : modules)) : ls)) + lopts copts +cmpSubMod env metaEnv (List ((List (Atom "import" : modules)) : ls)) lopts + copts@(CompileOptions thisFunc _ _ lastFunc) = do + Atom nextFunc <- _gensym "cmpSubMod" + code <- importAll env metaEnv modules lopts $ + CompileOptions thisFunc False False (Just nextFunc) + rest <- cmpSubMod env metaEnv (List ls) lopts $ + CompileOptions nextFunc False False lastFunc + stub <- case rest of + [] -> return [createFunctionStub nextFunc lastFunc] + _ -> return [] + return $ code ++ rest ++ stub +cmpSubMod env metaEnv (List (_ : ls)) lopts copts = + cmpSubMod env metaEnv (List ls) lopts copts +cmpSubMod _ _ _ _ (CompileOptions thisFunc _ _ lastFunc) = + return [createFunctionStub thisFunc lastFunc] + +-- |Compile module directives (expressions) in a module definition +cmpModExpr env metaEnv name (List ((List (Atom "include" : files)) : ls)) + lopts@(CompileLibraryOptions _ compileLisp) + copts@(CompileOptions thisFunc _ _ lastFunc) = do + dir <- LSC.evalLisp metaEnv $ List [Atom "module-name-prefix", + List [Atom "quote", name]] +-- TODO: this pattern is common with the one below in "begin", +-- should consolidate (or at least consider doing so) + Atom nextFunc <- _gensym "includeNext" + code <- includeAll env dir files compileInc lopts $ + CompileOptions thisFunc False False (Just nextFunc) + rest <- cmpModExpr env metaEnv name (List ls) lopts $ + CompileOptions nextFunc False False lastFunc + stub <- case rest of + [] -> return [createFunctionStub nextFunc lastFunc] + _ -> return [] + return $ code ++ rest ++ stub + where + compileInc (String dir) (String filename) entry exit = do + let path = dir ++ filename + path' <- LSC.findFileOrLib path + compileLisp env path' entry exit + +cmpModExpr env metaEnv name (List ((List (Atom "include-ci" : code)) : ls)) lopts copts = do + -- NOTE: per r7rs, ci should insert a fold-case directive. But husk does + -- not support that, so just do a regular include for now + cmpModExpr env metaEnv name + (List ((List (Atom "include" : code)) : ls)) lopts copts +cmpModExpr env metaEnv name (List ((List (Atom "body" : code)) : ls)) lopts copts = do + cmpModExpr env metaEnv name + (List ((List (Atom "begin" : code)) : ls)) lopts copts + +cmpModExpr env metaEnv name + (List ((List (Atom "begin" : code)) : ls)) + lopts@(CompileLibraryOptions compileBlock _) + copts@(CompileOptions thisFunc _ _ lastFunc) = do + Atom nextFunc <- _gensym "cmpSubModNext" + code <- compileBlock thisFunc (Just nextFunc) env [] code + rest <- cmpModExpr env metaEnv name (List ls) lopts $ + CompileOptions nextFunc False False lastFunc + stub <- case rest of + [] -> return [createFunctionStub nextFunc lastFunc] + _ -> return [] + return $ code ++ rest ++ stub +cmpModExpr env metaEnv name (List (_ : ls)) lopts copts = + cmpModExpr env metaEnv name (List ls) lopts copts +cmpModExpr _ _ _ _ _ copts@(CompileOptions thisFunc _ _ lastFunc) = + return [createFunctionStub thisFunc lastFunc] + +-- |Include one or more files for compilation +-- TODO: this pattern is used elsewhere (IE, importAll). could be generalized +includeAll env dir [file] include lopts + copts@(CompileOptions thisFunc _ _ lastFunc) = do + include dir file thisFunc lastFunc +includeAll env dir (f : fs) include lopts + copts@(CompileOptions thisFunc _ _ lastFunc) = do + Atom nextFunc <- _gensym "includeAll" + c <- include dir f thisFunc (Just nextFunc) + rest <- includeAll env dir fs include lopts $ + CompileOptions nextFunc False False lastFunc + stub <- case rest of + [] -> return [createFunctionStub nextFunc lastFunc] + _ -> return [] + return $ c ++ rest ++ stub +includeAll _ _ [] _ _ _ = return [] + +-- |Like evalLisp, but preserve pointers in the output +eval :: Env -> LispVal -> IOThrowsError LispVal +eval env lisp = do + LSC.meval env (makeNullContinuation env) lisp + diff --git a/hs-src/Language/Scheme/Compiler/Types.hs b/hs-src/Language/Scheme/Compiler/Types.hs new file mode 100644 --- /dev/null +++ b/hs-src/Language/Scheme/Compiler/Types.hs @@ -0,0 +1,242 @@ +{- | +Module : Language.Scheme.Compiler.Types +Copyright : Justin Ethier +Licence : MIT (see LICENSE in the distribution) + +Maintainer : github.com/justinethier +Stability : experimental +Portability : portable + +This module contains data types used by the compiler. +-} + +module Language.Scheme.Compiler.Types + ( + -- * Data types + CompOpts (CompileOptions) + , CompLibOpts (..) + , defaultCompileOptions + , HaskAST (..) + -- * Utility functions + , ast2Str + , asts2Str + , createAstFunc + , createAstCont + , joinL + , moduleRuntimeVar + , showValAST + -- * Headers appended to output file + , header + , headerComment + , headerModule + , headerImports + ) +where +import qualified Language.Scheme.Core as LSC (version) +import Language.Scheme.Types +import qualified Language.Scheme.Util (escapeBackslashes) +import qualified Data.Array +import qualified Data.ByteString as BS +import qualified Data.Complex as DC +import qualified Data.List +import qualified Data.Map +import qualified Data.Ratio as DR + +-- |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, + -- ^Immediate name to use when creating a compiled function. + -- Presumably there is other code that is expecting + -- to call into it. + + coptsThisFuncUseValue :: Bool, + -- ^Whether to include the 'value' parameter in the current function + + coptsThisFuncUseArgs :: Bool, + -- ^Whether to include the 'args' parameter in the current function + + coptsNextFunc :: Maybe String + -- ^The name to use for the next function after the current + -- compiler recursion is finished. For example, after compiling + -- a block of code, the control flow would be expected to go + -- to this function. + } + +defaultCompileOptions :: String -> CompOpts +defaultCompileOptions thisFunc = CompileOptions thisFunc False False Nothing + +-- |Options passed to the compiler library module +data CompLibOpts = CompileLibraryOptions { + compBlock :: String -> Maybe String -> Env + -> [HaskAST] -> [LispVal] -> IOThrowsError [HaskAST], + compLisp :: Env -> String -> String -> Maybe String + -> IOThrowsError [HaskAST] + } + +-- |Runtime reference to module data structure +moduleRuntimeVar = " modules " + +-- |Create code for a function +createAstFunc + :: CompOpts -- ^ Compilation options + -> [HaskAST] -- ^ Body of the function + -> HaskAST -- ^ Complete function code +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 ++ " ") funcBody + +-- |Create code for a continutation +createAstCont + :: CompOpts -- ^ Compilation options + -> String -- ^ Value to send to the continuation + -> String -- ^ Extra leading indentation (or blank string if none) + -> HaskAST -- ^ Generated code +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 + + +-- FUTURE: is this even necessary? Would just a string be good enough? + +-- |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 + } + +-- |Generate code based on the given Haskell AST +showValAST :: HaskAST -> String +showValAST (AstAssignM var val) = " " ++ var ++ " <- " ++ show val +showValAST (AstFunction name args code) = do + let fheader = "\n" ++ name ++ args ++ " = do " + let fbody = unwords . map (\x -> "\n" ++ x ) $ map showValAST code + fheader ++ fbody +showValAST (AstValue v) = v +showValAST (AstContinuation nextFunc args) = + " continueEval env (makeCPSWArgs env cont " ++ + nextFunc ++ " " ++ args ++ ") $ Nil \"\"" + +instance Show HaskAST where show = showValAST + +-- |A utility function to join list members together +joinL + :: forall a. [[a]] -- ^ Original list-of-lists + -> [a] -- ^ Separator + -> [a] -- ^ Joined list +joinL ls sep = concat $ Data.List.intersperse sep ls + +-- |Convert abstract syntax tree to a string +ast2Str :: LispVal -> String +ast2Str (String s) = "String " ++ show s +ast2Str (Char c) = "Char " ++ show c +ast2Str (Atom a) = "Atom " ++ show a +ast2Str (Number n) = "Number (" ++ show n ++ ")" +ast2Str (Complex c) = "Complex $ (" ++ (show $ DC.realPart c) ++ ") :+ (" ++ (show $ DC.imagPart c) ++ ")" +ast2Str (Rational r) = "Rational $ (" ++ (show $ DR.numerator r) ++ ") % (" ++ (show $ DR.denominator r) ++ ")" +ast2Str (Float f) = "Float (" ++ show f ++ ")" +ast2Str (Bool True) = "Bool True" +ast2Str (Bool False) = "Bool False" +ast2Str (HashTable ht) = do + let ls = Data.Map.toList ht + conv (a, b) = "(" ++ ast2Str a ++ "," ++ ast2Str b ++ ")" + "HashTable $ Data.Map.fromList $ [" ++ joinL (map conv ls) "," ++ "]" +ast2Str (Vector v) = do + let ls = Data.Array.elems v + size = (length ls) - 1 + "Vector (listArray (0, " ++ show size ++ ")" ++ "[" ++ joinL (map ast2Str ls) "," ++ "])" +ast2Str (ByteVector bv) = do + let ls = BS.unpack bv + "ByteVector ( BS.pack " ++ "[" ++ joinL (map show ls) "," ++ "])" +ast2Str (List ls) = "List [" ++ joinL (map ast2Str ls) "," ++ "]" +ast2Str (DottedList ls l) = + "DottedList [" ++ joinL (map ast2Str ls) "," ++ "] $ " ++ ast2Str l + +-- |Convert a list of abstract syntax trees to a list of strings +asts2Str :: [LispVal] -> String +asts2Str ls = do + "[" ++ (joinL (map ast2Str ls) ",") ++ "]" + +headerComment, headerModule, headerImports :: [String] +headerComment = [ + "--" + , "-- This file was automatically generated by the husk scheme compiler (huskc)" + , "--" + , "-- http://justinethier.github.io/husk-scheme " + , "-- (c) 2010 Justin Ethier " + , "-- Version " ++ LSC.version + , "--"] + +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 " + , " qualified Data.ByteString as BS " + , "Data.Complex " + , " qualified Data.Map " + , "Data.Ratio " + , "Data.Word " + , "System.IO "] + +header :: String -> Bool -> [String] +header filepath useCompiledLibs = do + let env = if useCompiledLibs + then "primitiveBindings" + else "r5rsEnv" + [ " " + , "-- |Get variable at runtime " + , "getRTVar env var = do " + , " v <- getVar env var " + , " return $ case v of " + , " List _ -> Pointer var env " + , " DottedList _ _ -> Pointer var env " + , " String _ -> Pointer var env " + , " Vector _ -> Pointer var env " + , " ByteVector _ -> Pointer var env " + , " HashTable _ -> Pointer var env " + , " _ -> v " + , " " + , "applyWrapper env cont (Nil _) (Just (a:as)) = do " + , " apply cont a as " + , " " + , "applyWrapper env cont value (Just (a:as)) = do " + , " apply cont a $ as ++ [value] " + , " " + , "getDataFileName' :: FilePath -> IO FilePath " + , "getDataFileName' name = return $ \"" ++ (Language.Scheme.Util.escapeBackslashes filepath) ++ "\" ++ name " + , " " + , "exec55_3 env cont _ _ = do " + , " liftIO $ registerExtensions env getDataFileName' " + , " continueEval env (makeCPS env cont exec) (Nil \"\")" + , " " + , "main :: IO () " + , "main = do " + , " env <- " ++ env ++ " " + , " result <- (runIOThrows $ liftM show $ hsInit env (makeNullContinuation env) (Nil \"\") Nothing) " + , " case result of " + , " Just errMsg -> putStrLn errMsg " + , " _ -> return () " + , " " + , "hsInit env cont _ _ = do " + , " _ <- defineVar env \"" ++ moduleRuntimeVar ++ "\" $ HashTable $ Data.Map.fromList [] " + , " run env cont (Nil \"\") []" + , " "] + diff --git a/hs-src/Language/Scheme/Core.hs b/hs-src/Language/Scheme/Core.hs --- a/hs-src/Language/Scheme/Core.hs +++ b/hs-src/Language/Scheme/Core.hs @@ -24,11 +24,14 @@ , runIOThrows , runIOThrowsREPL -- * Core data + , nullEnvWithImport , primitiveBindings , r5rsEnv + , r5rsEnv' -- , r7rsEnv , version -- * Utility functions + , findFileOrLib , getDataFileFullPath , registerExtensions , showBanner @@ -36,6 +39,8 @@ , substr , updateVector , updateByteVector + -- * Internal use only + , meval ) where import qualified Paths_husk_scheme as PHS (getDataFileName) #ifdef UseFfi @@ -61,7 +66,7 @@ -- |husk version number version :: String -version = "3.10" +version = "3.11" -- |A utility function to display the husk console banner showBanner :: IO () @@ -81,6 +86,26 @@ getDataFileFullPath :: String -> IO String getDataFileFullPath s = PHS.getDataFileName s +-- Future use: +-- getDataFileFullPath' :: [LispVal] -> IOThrowsError LispVal +-- getDataFileFullPath' [String s] = do +-- path <- liftIO $ PHS.getDataFileName s +-- return $ String path +-- getDataFileFullPath' [] = throwError $ NumArgs (Just 1) [] +-- getDataFileFullPath' args = throwError $ TypeMismatch "string" $ List args + +-- |Attempts to find the file both in the current directory and in the husk +-- libraries. If the file is not found in the current directory but exists +-- as a husk library, return the full path to the file in the library. +-- Otherwise just return the given filename. +findFileOrLib filename = do + fileAsLib <- liftIO $ getDataFileFullPath $ "lib/" ++ filename + exists <- fileExists [String filename] + existsLib <- fileExists [String fileAsLib] + case (exists, existsLib) of + (Bool False, Bool True) -> return fileAsLib + _ -> return filename + -- |Register optional SRFI extensions registerExtensions :: Env -> (FilePath -> IO FilePath) -> IO () registerExtensions env getDataFileName = do @@ -500,17 +525,21 @@ bound <- liftIO $ isRecBound env "string-set!" if bound then prepareApply env cont args -- if is bound to a variable in this scope; call into it - else meval env (makeCPS env cont cpsStr) i + else meval env (makeCPS env cont cpsChar) character where + cpsChar :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal + cpsChar e c chr _ = do + meval e (makeCPSWArgs e c cpsStr $ [chr]) i + cpsStr :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsStr e c idx _ = do + cpsStr e c idx (Just [chr]) = do value <- getVar env var derefValue <- derefPtr value - meval e (makeCPSWArgs e c cpsSubStr $ [idx]) derefValue + meval e (makeCPSWArgs e c cpsSubStr $ [idx, chr]) derefValue cpsSubStr :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsSubStr e c str (Just [idx]) = - substr (str, character, idx) >>= updateObject e var >>= continueEval e c + cpsSubStr e c str (Just [idx, chr]) = + substr (str, chr, idx) >>= updateObject e var >>= continueEval e c cpsSubStr _ _ _ _ = throwError $ InternalError "Invalid argument to cpsSubStr" eval env cont args@(List [Atom "string-set!" , nonvar , _ , _ ]) = do @@ -892,14 +921,34 @@ -- For the purposes of using husk as an extension language, /r5rsEnv/ will -- probably be more useful. primitiveBindings :: IO Env -primitiveBindings = nullEnv >>= (flip extendEnv $ map (domakeFunc IOFunc) ioPrimitives - ++ map (domakeFunc EvalFunc) evalFunctions - ++ map (domakeFunc PrimitiveFunc) primitives) - where domakeFunc constructor (var, func) = ((varNamespace, var), constructor func) +primitiveBindings = nullEnv >>= + (flip extendEnv $ map (domakeFunc IOFunc) ioPrimitives + ++ map (domakeFunc EvalFunc) evalFunctions + ++ map (domakeFunc PrimitiveFunc) primitives) + where domakeFunc constructor (var, func) = + ((varNamespace, var), constructor func) +-- |An empty environment with the %import function. This is presently +-- just intended for internal use by the compiler. +nullEnvWithImport :: IO Env +nullEnvWithImport = nullEnv >>= + (flip extendEnv [ + ((varNamespace, "%import"), EvalFunc evalfuncImport), + ((varNamespace, "hash-table-ref"), IOFunc $ wrapHashTbl hashTblRef)]) + -- |Load the standard r5rs environment, including libraries r5rsEnv :: IO Env r5rsEnv = do + env <- r5rsEnv' + -- Bit of a hack to load (import) + _ <- evalLisp' env $ List [Atom "%bootstrap-import"] + + return env + +-- |Load the standard r5rs environment, including libraries, +-- but do not create the (import) binding +r5rsEnv' :: IO Env +r5rsEnv' = do env <- primitiveBindings stdlib <- PHS.getDataFileName "lib/stdlib.scm" srfi55 <- PHS.getDataFileName "lib/srfi/srfi-55.scm" -- (require-extension) @@ -918,8 +967,6 @@ _ <- evalString metaEnv $ "(load \"" ++ (escapeBackslashes metalib) ++ "\")" -- Load meta-env so we can find it later _ <- evalLisp' env $ List [Atom "define", Atom "*meta-env*", LispEnv metaEnv] - -- Bit of a hack to load (import) - _ <- evalLisp' env $ List [Atom "%bootstrap-import"] -- Load (r5rs base) _ <- evalString metaEnv "(add-module! '(scheme r5rs) (make-module #f (interaction-environment) '()))" @@ -1056,13 +1103,15 @@ LispEnv e -> return toEnv Bool False -> do -- A hack to load imports into the main env, which - -- in modules.scm is the grandparent env + -- in modules.scm is the parent env case parentEnv env of - Just (Environment (Just gp) _ _) -> - return $ LispEnv gp - Just (Environment Nothing _ _ ) -> throwError $ InternalError "import into empty parent env" + Just env -> return $ LispEnv env Nothing -> throwError $ InternalError "import into empty env" case imports of + List [Bool False] -> do -- Export everything + exportAll toEnv' + Bool False -> do -- Export everything + exportAll toEnv' p@(Pointer _ _) -> do -- TODO: need to do this in a safer way List i <- derefPtr p -- Dangerous, but list is only expected obj @@ -1071,16 +1120,17 @@ List i -> do result <- moduleImport toEnv' fromEnv i continueEval env cont result - Bool False -> do -- Export everything - newEnv <- liftIO $ importEnv toEnv' fromEnv - continueEval - env - (Continuation env a b c d) - (LispEnv newEnv) + where + exportAll toEnv' = do + newEnv <- liftIO $ importEnv toEnv' fromEnv + continueEval + env + (Continuation env a b c d) + (LispEnv newEnv) -- This is just for debugging purposes: -evalfuncImport (cont@(Continuation env _ _ _ _ ) : cs) = do - continueEval env cont $ Nil "" +evalfuncImport args@(cont@(Continuation env _ _ _ _ ) : cs) = do + throwError $ TypeMismatch "import fields" $ List cs -- |Load import into the main environment bootstrapImport [cont@(Continuation env _ _ _ _)] = do @@ -1098,17 +1148,8 @@ evalfuncLoad [Continuation env a b c d, String filename] evalfuncLoad [cont@(Continuation env _ _ _ _), String filename] = do -{- --- It would be nice to use CPS style below. --- --- This code mostly works, but causes looping problems in t-cont. need to test to see if --- those are an artifact of this change or a code problem in that test suite: - code <- load filename - if not (null code) - then continueEval env (Continuation env (Just $ SchemeBody code) (Just cont) Nothing Nothing) $ Nil "" - else return $ Nil "" -- Empty, unspecified value --} - results <- load filename >>= mapM (evaluate env (makeNullContinuation env)) + filename' <- findFileOrLib filename + results <- load filename' >>= mapM (evaluate env (makeNullContinuation env)) if not (null results) then do result <- return . last $ results continueEval env cont result @@ -1283,6 +1324,9 @@ -- From SRFI 96 ("file-exists?", fileExists), ("delete-file", deleteFile), + + -- husk internal functions + --("husk-path", getDataFileFullPath'), -- Other I/O functions ("print-env", printEnv'), diff --git a/hs-src/Language/Scheme/Libraries.hs b/hs-src/Language/Scheme/Libraries.hs --- a/hs-src/Language/Scheme/Libraries.hs +++ b/hs-src/Language/Scheme/Libraries.hs @@ -42,6 +42,7 @@ file == "scheme/r5rs/read.sld" || file == "scheme/r5rs/write.sld" || file == "scheme/base.sld" || + file == "husk/pretty-print.sld" || -- TODO: scheme case-lambda (r7rs) -- TODO: scheme process-context (r7rs) -- TODO: scheme repl (r7rs) @@ -69,9 +70,8 @@ moduleImport to from is moduleImport to from [] = do return $ LispEnv to --- DEBUG: --- moduleImport to from unknown = do --- (trace ("MODULE IMPORT DEBUG: " ++ show unknown) return) $ Nil "" +moduleImport _ _ err = do + throwError $ Default $ "Unexpected argument to moduleImport: " ++ show err -- |Copy a binding from one env to another divertBinding diff --git a/hs-src/Language/Scheme/Primitives.hs b/hs-src/Language/Scheme/Primitives.hs --- a/hs-src/Language/Scheme/Primitives.hs +++ b/hs-src/Language/Scheme/Primitives.hs @@ -550,7 +550,9 @@ stringLength badArgList = throwError $ NumArgs (Just 1) badArgList stringRef :: [LispVal] -> IOThrowsError LispVal -stringRef [p@(Pointer _ _)] = derefPtr p >>= box >>= stringRef +stringRef [p@(Pointer _ _), k@(Number _)] = do + s <- derefPtr p + stringRef [s, k] stringRef [(String s), (Number k)] = return $ Char $ s !! fromInteger k stringRef [badType] = throwError $ TypeMismatch "string number" badType stringRef badArgList = throwError $ NumArgs (Just 2) badArgList diff --git a/hs-src/Language/Scheme/Types.hs b/hs-src/Language/Scheme/Types.hs --- a/hs-src/Language/Scheme/Types.hs +++ b/hs-src/Language/Scheme/Types.hs @@ -73,6 +73,7 @@ , LispEnv , EOF , Nil) + , nullLisp , toOpaque , fromOpaque , DeferredCode (..) @@ -260,6 +261,10 @@ -- ^ End of file indicator | Nil String -- ^Internal use only; do not use this type directly. + +-- | Scheme "null" value +nullLisp :: LispVal +nullLisp = List [] -- |Convert a Haskell value to an opaque Lisp value. toOpaque :: Typeable a => a -> LispVal diff --git a/hs-src/Language/Scheme/Variables.hs b/hs-src/Language/Scheme/Variables.hs --- a/hs-src/Language/Scheme/Variables.hs +++ b/hs-src/Language/Scheme/Variables.hs @@ -18,6 +18,7 @@ ( -- * Environments printEnv + , recPrintEnv , exportsFromEnv , copyEnv , extendEnv @@ -107,6 +108,16 @@ showVar (name, val) = do v <- liftIO $ readIORef val return $ "[" ++ name ++ "]" ++ ": " ++ show v + +recPrintEnv :: Env -> IO String +recPrintEnv env = do + envStr <- liftIO $ printEnv env + + case parentEnv env of + Just par -> do + parEnvStr <- liftIO $ recPrintEnv par + return $ envStr ++ "\n" ++ parEnvStr + Nothing -> return envStr -- |Return a list of symbols exported from an environment exportsFromEnv :: Env diff --git a/husk-scheme.cabal b/husk-scheme.cabal --- a/husk-scheme.cabal +++ b/husk-scheme.cabal @@ -1,5 +1,5 @@ Name: husk-scheme -Version: 3.10 +Version: 3.11 Synopsis: R5RS Scheme interpreter, compiler, and library. Description: <> @@ -42,7 +42,7 @@ ChangeLog.markdown LICENSE AUTHORS -Data-Files: lib/*.scm lib/scheme/*.sld lib/scheme/r5rs/*.sld lib/srfi/*.scm +Data-Files: lib/*.scm lib/husk/*.sld lib/husk/*.scm lib/scheme/*.sld lib/scheme/r5rs/*.sld lib/srfi/*.scm Source-Repository head Type: git @@ -68,6 +68,8 @@ Language.Scheme.Types Language.Scheme.Variables Language.Scheme.Compiler + Language.Scheme.Compiler.Libraries + Language.Scheme.Compiler.Types Language.Scheme.Plugins.CPUTime Language.Scheme.Macro Language.Scheme.Macro.ExplicitRenaming diff --git a/lib/husk/pp-sexp.scm b/lib/husk/pp-sexp.scm new file mode 100644 --- /dev/null +++ b/lib/husk/pp-sexp.scm @@ -0,0 +1,310 @@ +; +; Downloaded from: +; http://www.mathematik.uni-muenchen.de/~logik/download/minlog/src/pp-sexp.scm + +; JAE - required for below +(define pretty-print #f) +(begin +(define pp-width 80) +; End JAE changes + +;; We define a pretty printer for Scheme S-expressions (sexp). While +;; Petite Scheme supports that by its own, mzscheme does not. If you +;; get a sexp (like from proof-to-expr) prefix it with a call to spp and +;; the output is nicely formated to fit into pp-width many columns: +;; +;; (spp (proof-to-expr (current-proof))) +;; +;; If you want the sexp printed as a comment, use the +;; sexp-pretty-print->string function: +;; +;; (display-comment (sexp-pretty-print->string +;; (proof-to-expr (current-proof)))) +;; + +;;"genwrite.scm" generic write used by pretty-print and truncated-print. +;; Copyright (c) 1991, Marc Feeley +;; Author: Marc Feeley (feeley@iro.umontreal.ca) +;; Distribution restrictions: none +;; +;; Modified for Minlog by Stefan Schimanski +;; Taken from slib 2d6, genwrite.scm and pp.scm + +(define genwrite:newline-str (make-string 1 #\newline)) + +(define (generic-write obj display? width output) + + (define (read-macro? l) + (define (length1? l) (and (pair? l) (null? (cdr l)))) + (let ((head (car l)) (tail (cdr l))) + (case head + ((quote quasiquote unquote unquote-splicing) (length1? tail)) + (else #f)))) + + (define (read-macro-body l) + (cadr l)) + + (define (read-macro-prefix l) + (let ((head (car l)) (tail (cdr l))) + (case head + ((quote) "'") + ((quasiquote) "`") + ((unquote) ",") + ((unquote-splicing) ",@")))) + + (define (out str col) + (and col (output str) (+ col (string-length str)))) + + (define (wr obj col) + + (define (wr-expr expr col) + (if (read-macro? expr) + (wr (read-macro-body expr) (out (read-macro-prefix expr) col)) + (wr-lst expr col))) + + (define (wr-lst l col) + (if (pair? l) + (let loop ((l (cdr l)) + (col (and col (wr (car l) (out "(" col))))) + (cond ((not col) col) + ((pair? l) + (loop (cdr l) (wr (car l) (out " " col)))) + ((null? l) (out ")" col)) + (else (out ")" (wr l (out " . " col)))))) + (out "()" col))) + + (cond ((pair? obj) (wr-expr obj col)) + ((null? obj) (wr-lst obj col)) + ((vector? obj) (wr-lst (vector->list obj) (out "#" col))) + ((boolean? obj) (out (if obj "#t" "#f") col)) + ((number? obj) (out (number->string obj) col)) + ((symbol? obj) (out (symbol->string obj) col)) + ((procedure? obj) (out "#[procedure]" col)) + ((string? obj) (if display? + (out obj col) + (let loop ((i 0) (j 0) (col (out "\"" col))) + (if (and col (< j (string-length obj))) + (let ((c (string-ref obj j))) + (if (or (char=? c #\\) + (char=? c #\")) + (loop j + (+ j 1) + (out "\\" + (out (substring obj i j) + col))) + (loop i (+ j 1) col))) + (out "\"" + (out (substring obj i j) col)))))) + ((char? obj) (if display? + (out (make-string 1 obj) col) + (out (case obj + ((#\space) "space") + ((#\newline) "newline") + (else (make-string 1 obj))) + (out "#\\" col)))) + ((input-port? obj) (out "#[input-port]" col)) + ((output-port? obj) (out "#[output-port]" col)) + ((eof-object? obj) (out "#[eof-object]" col)) + (else (out "#[unknown]" col)))) + + (define (pp obj col) + + (define (spaces n col) + (if (> n 0) + (if (> n 7) + (spaces (- n 8) (out " " col)) + (out (substring " " 0 n) col)) + col)) + + (define (indent to col) + (and col + (if (< to col) + (and (out genwrite:newline-str col) (spaces to 0)) + (spaces (- to col) col)))) + + (define (pr obj col extra pp-pair) + (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines + (let ((result '()) + (left (min (+ (- (- width col) extra) 1) max-expr-width))) + (generic-write obj display? #f + (lambda (str) + (set! result (cons str result)) + (set! left (- left (string-length str))) + (> left 0))) + (if (> left 0) ; all can be printed on one line + (out (reverse-string-append result) col) + (if (pair? obj) + (pp-pair obj col extra) + (pp-list (vector->list obj) (out "#" col) extra pp-expr)))) + (wr obj col))) + + (define (pp-expr expr col extra) + (if (read-macro? expr) + (pr (read-macro-body expr) + (out (read-macro-prefix expr) col) + extra + pp-expr) + (let ((head (car expr))) + (if (symbol? head) + (let ((proc (style head))) + (if proc + (proc expr col extra) + (if (> (string-length (symbol->string head)) + max-call-head-width) + (pp-general expr col extra #f #f #f pp-expr) + (pp-call expr col extra pp-expr)))) + (pp-list expr col extra pp-expr))))) + + ; (head item1 + ; item2 + ; item3) + (define (pp-call expr col extra pp-item) + (let ((col* (wr (car expr) (out "(" col)))) + (and col + (pp-down (cdr expr) col* (+ col* 1) extra pp-item)))) + + ; (item1 + ; item2 + ; item3) + (define (pp-list l col extra pp-item) + (let ((col (out "(" col))) + (pp-down l col col extra pp-item))) + + (define (pp-down l col1 col2 extra pp-item) + (let loop ((l l) (col col1)) + (and col + (cond ((pair? l) + (let ((rest (cdr l))) + (let ((extra (if (null? rest) (+ extra 1) 0))) + (loop rest + (pr (car l) (indent col2 col) extra pp-item))))) + ((null? l) + (out ")" col)) + (else + (out ")" + (pr l + (indent col2 (out "." (indent col2 col))) + (+ extra 1) + pp-item))))))) + + (define (pp-general expr col extra named? pp-1 pp-2 pp-3) + + (define (tail1 rest col1 col2 col3) + (if (and pp-1 (pair? rest)) + (let* ((val1 (car rest)) + (rest (cdr rest)) + (extra (if (null? rest) (+ extra 1) 0))) + (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3)) + (tail2 rest col1 col2 col3))) + + (define (tail2 rest col1 col2 col3) + (if (and pp-2 (pair? rest)) + (let* ((val1 (car rest)) + (rest (cdr rest)) + (extra (if (null? rest) (+ extra 1) 0))) + (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2))) + (tail3 rest col1 col2))) + + (define (tail3 rest col1 col2) + (pp-down rest col2 col1 extra pp-3)) + + (let* ((head (car expr)) + (rest (cdr expr)) + (col* (wr head (out "(" col)))) + (if (and named? (pair? rest)) + (let* ((name (car rest)) + (rest (cdr rest)) + (col** (wr name (out " " col*)))) + (tail1 rest (+ col indent-general) col** (+ col** 1))) + (tail1 rest (+ col indent-general) col* (+ col* 1))))) + + (define (pp-expr-list l col extra) + (pp-list l col extra pp-expr)) + + (define (pp-LAMBDA expr col extra) + (pp-general expr col extra #f pp-expr-list #f pp-expr)) + + (define (pp-IF expr col extra) + (pp-general expr col extra #f pp-expr #f pp-expr)) + + (define (pp-COND expr col extra) + (pp-call expr col extra pp-expr-list)) + + (define (pp-CASE expr col extra) + (pp-general expr col extra #f pp-expr #f pp-expr-list)) + + (define (pp-AND expr col extra) + (pp-call expr col extra pp-expr)) + + (define (pp-LET expr col extra) + (let* ((rest (cdr expr)) + (named? (and (pair? rest) (symbol? (car rest))))) + (pp-general expr col extra named? pp-expr-list #f pp-expr))) + + (define (pp-BEGIN expr col extra) + (pp-general expr col extra #f #f #f pp-expr)) + + (define (pp-DO expr col extra) + (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr)) + + ; define formatting style (change these to suit your style) + + (define indent-general 2) + + (define max-call-head-width 5) + + (define max-expr-width 50) + + (define (style head) + (case head + ((lambda let* letrec define) pp-LAMBDA) + ((if set!) pp-IF) + ((cond) pp-COND) + ((case) pp-CASE) + ((and or) pp-AND) + ((let) pp-LET) + ((begin) pp-BEGIN) + ((do) pp-DO) + (else #f))) + + (pr obj col 0 pp-expr)) + + (if width + (out genwrite:newline-str (pp obj 0)) + (wr obj 0))) + +; (reverse-string-append l) = (apply string-append (reverse l)) + +(define (reverse-string-append l) + + (define (rev-string-append l i) + (if (pair? l) + (let* ((str (car l)) + (len (string-length str)) + (result (rev-string-append (cdr l) (+ i len)))) + (let loop ((j 0) (k (- (- (string-length result) i) len))) + (if (< j len) + (begin + (string-set! result k (string-ref str j)) + (loop (+ j 1) (+ k 1))) + result))) + (make-string i))) + + (rev-string-append l 0)) + +(define (sexp-pretty-print obj . opt) + (let ((port (if (pair? opt) (car opt) (current-output-port)))) + (generic-write obj #f pp-width + (lambda (s) (display s port) #t)) + (display ""))) + +(define (sexp-pretty-print->string obj . width) + (define result '()) + (generic-write obj #f (if (null? width) pp-width (car width)) + (lambda (str) (set! result (cons str result)) #t)) + (reverse-string-append result)) + +(define spp sexp-pretty-print) +(set! pretty-print spp) +) + diff --git a/lib/husk/pretty-print.sld b/lib/husk/pretty-print.sld new file mode 100644 --- /dev/null +++ b/lib/husk/pretty-print.sld @@ -0,0 +1,4 @@ +(define-library (husk pretty-print) + (export pretty-print) + (import (scheme r5rs)) + (include "pp-sexp.scm")) diff --git a/lib/modules.scm b/lib/modules.scm --- a/lib/modules.scm +++ b/lib/modules.scm @@ -8,7 +8,7 @@ ;;; used to implement modules (r7rs libraries) in husk ;;; -;; meta.scm -- meta langauge for describing modules +;; meta.scm -- meta language for describing modules ;; Copyright (c) 2009-2012 Alex Shinn. All rights reserved. ;; BSD-style license: http://synthcode.com/license.txt @@ -157,10 +157,11 @@ (cond ((find-module-file f) => (lambda (path) - (cond (fold? - (let ((in (open-input-file path))) - (set-port-fold-case! in #t) - (load in env))) + ;; JAE + (cond ;(fold? + ; (let ((in (open-input-file path))) + ; (set-port-fold-case! in #t) + ; (load in env))) (else (load path env))))) (else (error "couldn't find include" f))))) @@ -187,8 +188,9 @@ (load-modules (cdr x) "" #f)) ((include-ci) (load-modules (cdr x) "" #t)) - ((include-shared) - (load-modules (cdr x) *shared-object-extension* #f)) + ;; JAE + ;((include-shared) + ; (load-modules (cdr x) *shared-object-extension* #f)) ((body begin) (for-each (lambda (expr) diff --git a/lib/scheme/r5rs/base.sld b/lib/scheme/r5rs/base.sld --- a/lib/scheme/r5rs/base.sld +++ b/lib/scheme/r5rs/base.sld @@ -78,8 +78,8 @@ for-each gcd import - include - include-ci + ;include + ;include-ci inexact->exact ; r5rs definition input-port? integer->char diff --git a/lib/stdlib.scm b/lib/stdlib.scm --- a/lib/stdlib.scm +++ b/lib/stdlib.scm @@ -102,6 +102,17 @@ ((begin exp ...) ((lambda () exp ...))))) +; +; +; NOTE: The below cond/case forms do NOT use begin to prevent +; conflicts between the stdlib begin and the begin form +; from the module metalanguage. +; +; TODO: this may indicate a problem with syntax-rules and +; referential transparency. +; +; + ; cond ; Form from R5RS: (define-syntax cond @@ -119,8 +130,7 @@ ; updated to take this into acccount, so the pitfall ; still fails ; - ;(begin result1 result2 ...)) ;; TODO: should use begin - ((lambda () result1 result2 ...))) ;; TODO: should use begin + ((lambda () result1 result2 ...))) ;; Intentionally not using begin, see above ((cond (test => result)) (let ((temp test)) (if temp (result temp)))) @@ -136,13 +146,11 @@ temp (cond clause1 clause2 ...)))) ((cond (test result1 result2 ...)) - ;(if test (begin result1 result2 ...))) ;; TODO: should use begin - (if test ((lambda () result1 result2 ...)))) ;; TODO: should use begin + (if test ((lambda () result1 result2 ...)))) ;; Intentionally not using begin, see above ((cond (test result1 result2 ...) clause1 clause2 ...) (if test - ;(begin result1 result2 ...) ;; TODO: should use begin - ((lambda () result1 result2 ...)) ;; TODO: should use begin + ((lambda () result1 result2 ...)) ;; Intentionally not using begin, see above (cond clause1 clause2 ...))))) ; Case ; Form from R5RS: @@ -154,19 +162,16 @@ (case atom-key clauses ...))) ((case key (else result1 result2 ...)) - ;(if #t (begin result1 result2 ...))) ;; TODO: should use begin - (if #t ((lambda () result1 result2 ...)))) ;; TODO: should use begin + (if #t ((lambda () result1 result2 ...)))) ;; Intentionally not using begin, see above ((case key ((atoms ...) result1 result2 ...)) (if (memv key '(atoms ...)) - ;(begin result1 result2 ...))) ;; TODO: should use begin - ((lambda () result1 result2 ...)))) ;; TODO: should use begin + ((lambda () result1 result2 ...)))) ;; Intentionally not using begin, see above ((case key ((atoms ...) result1 result2 ...) clause clauses ...) (if (memv key '(atoms ...)) - ;(begin result1 result2 ...) ;; TODO: should use begin - ((lambda () result1 result2 ...)) ;; TODO: should use begin + ((lambda () result1 result2 ...)) ;; Intentionally not using begin, see above (case key clause clauses ...))))) (define (my-mem-helper obj lst cmp-proc)