husk-scheme 3.10 → 3.11

raw patch · 17 files changed

+1347/−360 lines, 17 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.markdown +16/−0
• README.markdown +1/−1
• hs-src/Compiler/huskc.hs +13/−14
• hs-src/Language/Scheme/Compiler.hs +299/−283
• hs-src/Language/Scheme/Compiler/Libraries.hs +329/−0
• hs-src/Language/Scheme/Compiler/Types.hs +242/−0
• hs-src/Language/Scheme/Core.hs +79/−35
• hs-src/Language/Scheme/Libraries.hs +3/−3
• hs-src/Language/Scheme/Primitives.hs +3/−1
• hs-src/Language/Scheme/Types.hs +5/−0
• hs-src/Language/Scheme/Variables.hs +11/−0
• husk-scheme.cabal +4/−2
• lib/husk/pp-sexp.scm +310/−0
• lib/husk/pretty-print.sld +4/−0
• lib/modules.scm +9/−7
• lib/scheme/r5rs/base.sld +2/−2
• lib/stdlib.scm +17/−12

@@ -1,3 +1,19 @@++v3.11+--------++The major change in this release is support for R<sup>7</sup>RS 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 R<sup>7</sup>RS.++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 -------- 

@@ -1,6 +1,6 @@ [<img src="https://github.com/justinethier/husk-scheme/raw/master/docs/husk-scheme.png" alt="husk-scheme">](http://justinethier.github.com/husk-scheme) -husk is a dialect of Scheme written in Haskell that adheres to the [R<sup>5</sup>RS standard](http://www.schemers.org/Documents/Standards/R5RS/HTML/). Advanced R<sup>5</sup>RS 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 [R<sup>5</sup>RS standard](http://www.schemers.org/Documents/Standards/R5RS/HTML/). Advanced R<sup>5</sup>RS 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 R<sup>5</sup>RS standard, the intent is to develop a Scheme that is as compatible as possible with other R<sup>5</sup>RS Schemes. husk is mature enough for use in production applications, however it is not optimized for performance-critical applications.  

@@ -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

@@ -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

@@ -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+

@@ -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 \"\") []"+    , " "]+

@@ -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'),

@@ -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

@@ -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

@@ -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

@@ -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 

@@ -1,5 +1,5 @@ Name:                husk-scheme-Version:             3.10+Version:             3.11 Synopsis:            R5RS Scheme interpreter, compiler, and library. Description:            <<https://github.com/justinethier/husk-scheme/raw/master/docs/husk-scheme.png>>@@ -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

@@ -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 <schimans@math.lmu.de>+;; 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)+)+

@@ -0,0 +1,4 @@+(define-library (husk pretty-print)+    (export pretty-print)+    (import (scheme r5rs))+    (include "pp-sexp.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) 

@@ -78,8 +78,8 @@     for-each     gcd     import-    include-    include-ci+    ;include+    ;include-ci     inexact->exact ; r5rs definition     input-port?     integer->char

@@ -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)