husk-scheme 3.15.2 → 3.16
raw patch · 14 files changed
+391/−136 lines, 14 filesdep +knob
Dependencies added: knob
Files
- ChangeLog.markdown +39/−0
- hs-src/Compiler/huskc.hs +11/−11
- hs-src/Interpreter/shell.hs +28/−26
- hs-src/Language/Scheme/Compiler.hs +97/−36
- hs-src/Language/Scheme/Compiler/Libraries.hs +1/−1
- hs-src/Language/Scheme/Compiler/Types.hs +5/−4
- hs-src/Language/Scheme/Core.hs +13/−3
- hs-src/Language/Scheme/Environments.hs +9/−1
- hs-src/Language/Scheme/Primitives.hs +147/−34
- hs-src/Language/Scheme/Types.hs +3/−2
- husk-scheme.cabal +2/−2
- lib/core.scm +16/−6
- lib/modules.scm +19/−10
- lib/scheme/base.sld +1/−0
ChangeLog.markdown view
@@ -1,3 +1,42 @@+v3.16+--------++- Improved import of libraries:++ - Husk now detects cyclic dependencies and throws an error instead of going into an infinite loop.+ - Each library is only evaluated once during the import process.++- `begin` now has the ability to evaluate contained expressions and definitions as if the enclosing `begin` were not present, per R<sup>7</sup>RS. For example:++ huski> x+ Getting an unbound variable: x+ huski> (begin (define x 28) x)+ 28+ huski> x+ 28++- Added the following R<sup>7</sup>RS I/O functions: ++ - `get-output-bytevector`+ - `get-output-string`+ - `open-input-bytevector`+ - `open-input-string`+ - `open-output-bytevector`+ - `open-output-string`+ - `read-string`+ - `write-string`++- Added an `-i` command line option to `huski`. This option will start the interactive REPL after a file specified on the command line is executed, and has no effect if no file is specified.++Haskell API:++- The `Port` data type has been extended to include an optional in-memory buffer:+ + Port Handle (Maybe Knob)++ These changes are isolated in husk, but if your code uses any `Port` constructors, you would need to change them, EG: `Port _ Nothing`.++ v3.15.2 --------
hs-src/Compiler/huskc.hs view
@@ -106,17 +106,17 @@ putStrLn "" putStrLn " Options:" putStrLn ""- putStrLn " --help Display this information"- putStrLn " --version Display husk version information"- putStrLn " --revision rev Specify the scheme revision to use:"- putStrLn ""- putStrLn " 5 - r5rs (default)"- putStrLn " 7 - r7rs small"- putStrLn ""- putStrLn " --output filename Write executable to the given filename"- putStrLn " --dynamic Use dynamic Haskell libraries, if available"- putStrLn " (Requires libraries built via --enable-shared)"- putStrLn " --extra args Pass extra arguments directly to ghc"+ putStrLn " -h, --help Display this information"+ putStrLn " -V, --version Display husk version information"+-- putStrLn " --revision rev Specify the scheme revision to use:"+-- putStrLn ""+-- putStrLn " 5 - r5rs (default)"+-- putStrLn " 7 - r7rs small"+-- putStrLn ""+ putStrLn " -o, --output filename Write executable to the given filename"+ putStrLn " -d, --dynamic Use dynamic Haskell libraries, if available"+ putStrLn " (Requires libraries built via --enable-shared)"+ putStrLn " -x, --extra args Pass extra arguments directly to ghc" putStrLn "" exitWith ExitSuccess
hs-src/Interpreter/shell.hs view
@@ -32,33 +32,39 @@ let (actions, nonOpts, _) = getOpt Permute options args opts <- foldl (>>=) (return defaultOptions) actions- let Options {optSchemeRev = schemeRev} = opts+ let Options {optInter = interactive, optSchemeRev = schemeRev} = opts - if null nonOpts + if null nonOpts then do LSC.showBanner- runRepl schemeRev- else runOne schemeRev nonOpts+ env <- liftIO $ getRuntimeEnv schemeRev+ runRepl env+ else do+ runOne (getRuntimeEnv schemeRev) nonOpts interactive -- -- Command line options section -- data Options = Options {+ optInter :: Bool, optSchemeRev :: String -- RxRS version } -- |Default values for the command line options defaultOptions :: Options defaultOptions = Options {+ optInter = False, optSchemeRev = "5" } options :: [OptDescr (Options -> IO Options)] options = [+ Option ['i'] ["interactive"] (NoArg getInter) "load file and run REPL", Option ['r'] ["revision"] (ReqArg writeRxRSVersion "Scheme") "scheme RxRS version", Option ['h', '?'] ["help"] (NoArg showHelp) "show usage information" ] where+ getInter opt = return opt { optInter = True } writeRxRSVersion arg opt = return opt { optSchemeRev = arg } showHelp :: Options -> IO Options@@ -72,11 +78,13 @@ putStrLn "" putStrLn " Options may be any of the following:" putStrLn ""- putStrLn " --help Display this information"- putStrLn " --revision rev Specify the scheme revision to use:"- putStrLn ""- putStrLn " 5 - r5rs (default)"- putStrLn " 7 - r7rs small"+ putStrLn " -h, --help Display this information"+ putStrLn " -i Start interactive REPL after file is executed. This"+ putStrLn " option has no effect if a file is not specified. "+-- putStrLn " --revision rev Specify the scheme revision to use:"+-- putStrLn ""+-- putStrLn " 5 - r5rs (default)"+-- putStrLn " 7 - r7rs small" putStrLn "" exitWith ExitSuccess @@ -87,20 +95,20 @@ flushStr :: String -> IO () flushStr str = putStr str >> hFlush stdout --- |Execute a single scheme file from the command line-runOne :: String -> [String] -> IO ()-runOne "7" args = runOneWenv LSC.r7rsEnv args-runOne _ args = runOneWenv LSC.r5rsEnv args+getRuntimeEnv :: String -> IO Env+getRuntimeEnv "7" = LSC.r7rsEnv+getRuntimeEnv _ = LSC.r5rsEnv -runOneWenv :: IO Env -> [String] -> IO ()-runOneWenv initEnv args = do+-- |Execute a single scheme file from the command line+runOne :: IO Env -> [String] -> Bool -> IO ()+runOne initEnv args interactive = do env <- initEnv >>= flip LSV.extendEnv [((LSV.varNamespace, "args"), List $ map String $ drop 1 args)] result <- (LSC.runIOThrows $ liftM show $ LSC.evalLisp env (List [Atom "load", String (args !! 0)]))- case result of+ _ <- case result of Just errMsg -> putStrLn errMsg _ -> do -- Call into (main) if it exists...@@ -112,18 +120,12 @@ case mainResult of Just errMsg -> putStrLn errMsg _ -> return ())+ when interactive (do+ runRepl env) -- |Start the REPL (interactive interpreter)-runRepl :: String -> IO ()-runRepl "7" = do- env <- liftIO $ LSC.r7rsEnv- runReplWenv env-runRepl _ = do- env <- liftIO $ LSC.r5rsEnv - runReplWenv env--runReplWenv :: Env -> IO ()-runReplWenv env' = do+runRepl :: Env -> IO ()+runRepl env' = do let settings = HL.Settings (completeScheme env') Nothing True HL.runInputT settings (loop env') where
hs-src/Language/Scheme/Compiler.hs view
@@ -306,8 +306,8 @@ -- Entry point; ensure if is not rebound f <- return [AstValue $ " " ++ symPredicate ++- " env (makeCPS env cont " ++ symCheckPredicate ++ ") " ++ - " (Nil \"\") [] "]+ " env (makeCPSWArgs env cont " ++ symCheckPredicate ++ " []) " ++ + " (Nil \"\") (Just []) "] -- Compile expression for if's args compPredicate <- compileExpr env predic symPredicate Nothing -- Do not want to call into nextFunc in the middle of (if) compConsequence <- compileExpr env conseq symConsequence nextFunc -- pick up at nextFunc after consequence@@ -315,8 +315,8 @@ -- Special case because we need to check the predicate's value compCheckPredicate <- return $ AstFunction symCheckPredicate " env cont result _ " [ AstValue $ " case result of ",- AstValue $ " Bool False -> " ++ symAlternate ++ " env cont (Nil \"\") [] ",- AstValue $ " _ -> " ++ symConsequence ++ " env cont (Nil \"\") [] "]+ AstValue $ " Bool False -> " ++ symAlternate ++ " env cont (Nil \"\") (Just []) ",+ AstValue $ " _ -> " ++ symConsequence ++ " env cont (Nil \"\") (Just []) "] -- Join compiled code together return $ [createAstFunc copts f] ++ compPredicate ++ [compCheckPredicate] ++ @@ -368,7 +368,7 @@ -- Entry point; ensure var is not rebound f <- return $ [- AstValue $ " " ++ symDefine ++ " env cont (Nil \"\") []" ]+ AstValue $ " " ++ symDefine ++ " env cont (Nil \"\") (Just [])" ] compDefine <- compileExpr env form symDefine $ Just symMakeDefine compMakeDefine <- return $ AstFunction symMakeDefine " env cont result _ " [ AstValue $ " _ <- defineVar env \"" ++ var ++ "\" result",@@ -496,7 +496,7 @@ compChr <- compileExpr env character symChr $ Just symDefine compDefine <- return $ AstFunction symDefine " env cont chr _ " [ AstValue $ " " ++ symCompiledI ++ " env (makeCPSWArgs env cont " ++ - symMakeDefine ++ " [chr]) (Nil \"\") Nothing " ]+ symMakeDefine ++ " [chr]) (Nil \"\") (Just []) " ] compI <- compileExpr env i symCompiledI Nothing compMakeDefine <- return $ AstFunction symMakeDefine " env cont idx (Just [chr]) " [ AstValue $ " tmp <- getVar env \"" ++ var ++ "\"",@@ -526,7 +526,7 @@ -- Code to all into next continuation from copts, if one exists let finalContinuation = case copts of- (CompileOptions _ _ _ (Just nextFunc)) -> "continueEval e (makeCPS e c " ++ nextFunc ++ ")\n"+ (CompileOptions _ _ _ (Just nextFunc)) -> "continueEval e (makeCPSWArgs e c " ++ nextFunc ++ " [])\n" _ -> "continueEval e c\n" -- Entry point that allows set-car! to be redefined@@ -536,7 +536,7 @@ compGetVar <- return $ AstFunction symGetVar " env cont idx _ " [ AstValue $ " result <- getVar env \"" ++ var ++ "\"", AstValue $ " derefValue <- recDerefPtrs result",- AstValue $ " " ++ symObj ++ " env cont derefValue Nothing "]+ AstValue $ " " ++ symObj ++ " env cont derefValue (Just []) "] -- Compiled version of argObj compiledObj <- compileExpr env argObj symCompiledObj Nothing @@ -588,7 +588,7 @@ -- Code to all into next continuation from copts, if one exists let finalContinuation = case copts of- (CompileOptions _ _ _ (Just nextFunc)) -> "continueEval e (makeCPS e c " ++ nextFunc ++ ")\n"+ (CompileOptions _ _ _ (Just nextFunc)) -> "continueEval e (makeCPSWArgs e c " ++ nextFunc ++ " [])\n" _ -> "continueEval e c\n" -- Entry point that allows set-car! to be redefined@@ -598,7 +598,7 @@ compGetVar <- return $ AstFunction symGetVar " env cont idx _ " [ AstValue $ " result <- getVar env \"" ++ var ++ "\"", AstValue $ " derefValue <- recDerefPtrs result",- AstValue $ " " ++ symObj ++ " env cont derefValue Nothing "]+ AstValue $ " " ++ symObj ++ " env cont derefValue (Just []) "] -- Compiled version of argObj compiledObj <- compileExpr env argObj symCompiledObj Nothing @@ -660,7 +660,7 @@ -- Compile index, then use a wrapper to pass it as an arg while compiling obj compiledIdx <- compileExpr env i symCompiledIdx (Just symIdxWrapper) compiledIdxWrapper <- return $ AstFunction symIdxWrapper " env cont idx _ " [- AstValue $ " " ++ symCompiledObj ++ " env (makeCPSWArgs env cont " ++ symUpdateVec ++ " [idx]) (Nil \"\") Nothing " ]+ AstValue $ " " ++ symCompiledObj ++ " env (makeCPSWArgs env cont " ++ symUpdateVec ++ " [idx]) (Nil \"\") (Just []) " ] compiledObj <- compileExpr env object symCompiledObj Nothing -- Do actual update compiledUpdate <- return $ AstFunction symUpdateVec " env cont obj (Just [idx]) " [@@ -693,7 +693,7 @@ -- Compile index, then use a wrapper to pass it as an arg while compiling obj compiledIdx <- compileExpr env i symCompiledIdx (Just symIdxWrapper) compiledIdxWrapper <- return $ AstFunction symIdxWrapper " env cont idx _ " [- AstValue $ " " ++ symCompiledObj ++ " env (makeCPSWArgs env cont " ++ symUpdateVec ++ " [idx]) (Nil \"\") Nothing " ]+ AstValue $ " " ++ symCompiledObj ++ " env (makeCPSWArgs env cont " ++ symUpdateVec ++ " [idx]) (Nil \"\") (Just []) " ] compiledObj <- compileExpr env object symCompiledObj Nothing -- Do actual update compiledUpdate <- return $ AstFunction symUpdateVec " env cont obj (Just [idx]) " [@@ -727,7 +727,7 @@ -- Compile index, then use a wrapper to pass it as an arg while compiling obj compiledIdx <- compileExpr env i symCompiledIdx (Just symIdxWrapper) compiledIdxWrapper <- return $ AstFunction symIdxWrapper " env cont idx _ " [- AstValue $ " " ++ symCompiledObj ++ " env (makeCPSWArgs env cont " ++ symUpdateVec ++ " [idx]) (Nil \"\") Nothing " ]+ AstValue $ " " ++ symCompiledObj ++ " env (makeCPSWArgs env cont " ++ symUpdateVec ++ " [idx]) (Nil \"\") (Just []) " ] compiledObj <- compileExpr env object symCompiledObj Nothing -- Do actual update compiledUpdate <- return $ AstFunction symUpdateVec " env cont obj (Just [idx]) " [@@ -760,7 +760,7 @@ -- Compile index, then use a wrapper to pass it as an arg while compiling obj compiledIdx <- compileExpr env rkey symCompiledIdx (Just symIdxWrapper) compiledIdxWrapper <- return $ AstFunction symIdxWrapper " env cont idx _ " [- AstValue $ " " ++ symCompiledObj ++ " env (makeCPSWArgs env cont " ++ symUpdateVec ++ " [idx]) (Nil \"\") Nothing " ]+ AstValue $ " " ++ symCompiledObj ++ " env (makeCPSWArgs env cont " ++ symUpdateVec ++ " [idx]) (Nil \"\") (Just []) " ] compiledObj <- compileExpr env rvalue symCompiledObj Nothing -- Do actual update compiledUpdate <- return $ AstFunction symUpdateVec " env cont obj (Just [rkey]) " [@@ -856,7 +856,7 @@ f <- return $ [ -- TODO: should do runtime error checking if something else -- besides a LispEnv is returned- AstValue $ " LispEnv e <- " ++ symEnv ++ " env (makeNullContinuation env) (Nil \"\") [] ",+ AstValue $ " LispEnv e <- " ++ symEnv ++ " env (makeNullContinuation env) (Nil \"\") (Just []) ", AstValue $ " result <- " ++ symLoad ++ " e (makeNullContinuation e) (Nil \"\") Nothing", createAstCont copts "result" ""] -- Join compiled code together@@ -947,7 +947,7 @@ _ -> "Nil \"\"" args = case useArgs of True -> "(Just args)"- _ -> "Nothing"+ _ -> "(Just [])" comp (List [Atom renamed, Atom orig]) = do [AstValue $ " v <- getVar env \"" ++ orig ++ "\"", AstValue $ " _ <- defineVar env \"" ++ renamed ++ "\" v"]@@ -960,7 +960,7 @@ -- |Create the function entry point for a special form compileSpecialFormEntryPoint :: String -> String -> CompOpts -> IOThrowsError HaskAST compileSpecialFormEntryPoint formName formSym copts = do- compileSpecialForm formName ("do " ++ formSym ++ " env cont (Nil \"\") []") copts+ compileSpecialForm formName ("" ++ formSym ++ " env cont (Nil \"\") (Just [])") copts -- | Helper function for compiling a special form compileSpecialForm :: String -> String -> CompOpts -> IOThrowsError HaskAST@@ -999,6 +999,11 @@ -- -- TODO: it is probably possible to mix creating conts and not when there are func and non-func args. -- +-- _ <- case (trace ("calling compileApply: " ++ show (List (func : fparams))) func) of+ _ <- case func of+ List _ -> return $ Nil ""+ Atom _ -> return $ Nil "" + _ -> throwError $ BadSpecialForm "Unable to evaluate form" $ List (func : fparams) primitive <- isPrim env func let literals = collectLiterals fparams @@ -1055,8 +1060,8 @@ c <- return $ AstFunction coptsThis " env cont _ _ " [- AstValue $ " continueEval env (makeCPS env (makeCPS env cont " ++ - nextFunc ++ ") " ++ stubFunc ++ ") $ Nil\"\""] + AstValue $ " continueEval env (makeCPSWArgs env (makeCPSWArgs env cont " ++ + nextFunc ++ " []) " ++ stubFunc ++ " []) $ Nil\"\""] _comp <- mcompile env fnc $ CompileOptions stubFunc False False Nothing -- Haskell variables must be used to retrieve each atom from the env@@ -1073,11 +1078,31 @@ Just fnextExpr -> return $ [ AstFunction nextFunc " env cont value _ " $ varLines ++ - [AstValue $ " apply (makeCPS env cont " ++ - fnextExpr ++ ") value " ++ args]]+ [AstValue $ " apply (makeCPSWArgs env cont " ++ + fnextExpr ++ " []) value " ++ args]] return $ [c] ++ _comp ++ rest -- |Compile function and args as a chain of continuations+-- TODO:+ compileAllArgs (Atom fncName) = do+ rest <- case fparams of+ --rest <- case (trace "fncName" fparams) of+ [] -> do+ throwError $ Default $ " unreachable code in compileAllArgs for " ++ fncName+-- fnc <- compileInlineVar env fncName "fnc"+-- return [AstFunction +-- coptsThis+-- " env cont (Nil _) (Just (a:as)) "+-- [fnc,+-- AstValue $ " apply " ++ applyCont ++ " fnc (a:as) "],+-- AstFunction +-- coptsThis+-- " env cont value (Just (a:as)) " +-- [fnc,+-- AstValue $ " apply " ++ applyCont ++ " fnc $ (a:as) ++ [value] "]]+ _ -> compileArgs coptsThis True (Just fncName) fparams -- True, passing fnc as value+ return $ rest+ --return $ [c, wrapper ] ++ _comp ++ rest compileAllArgs func' = do Atom stubFunc <- _gensym "applyStubF" Atom wrapperFunc <- _gensym "applyWrapper"@@ -1085,8 +1110,8 @@ c <- return $ AstFunction coptsThis " env cont _ _ " [- AstValue $ " continueEval env (makeCPS env (makeCPS env cont " ++ - wrapperFunc ++ ") " ++ stubFunc ++ ") $ Nil\"\""] + AstValue $ " continueEval env (makeCPSWArgs env (makeCPSWArgs 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 _ " [@@ -1104,46 +1129,57 @@ nextFunc " env cont value (Just (a:as)) " [AstValue $ " apply " ++ applyCont ++ " a $ as ++ [value] "]]- _ -> compileArgs nextFunc False fparams -- False since no value passed in this time+ _ -> compileArgs nextFunc False Nothing fparams -- False since no value passed in this time return $ [c, wrapper ] ++ _comp ++ rest applyCont :: String applyCont = case coptsNext of Nothing -> "cont"- Just fnextExpr -> "(makeCPS env cont " ++ fnextExpr ++ ")"+ Just fnextExpr -> "(makeCPSWArgs env cont " ++ fnextExpr ++ " [])" -- |Compile each argument as its own continuation (lambda), and then -- call the function using "applyWrapper"- compileArgs :: String -> Bool -> [LispVal] -> IOThrowsError [HaskAST]- compileArgs thisFunc thisFuncUseValue args = do+ compileArgs :: String -> Bool -> (Maybe String) -> [LispVal] -> IOThrowsError [HaskAST]+ compileArgs thisFunc thisFuncUseValue maybeFnc args = do case args of (a:as) -> do- let lastArg = null as+ let (asRest, asLiterals) = (as, []) --TODO: takeLiterals a as+ let lastArg = null asRest Atom stubFunc <- _gensym "applyFirstArg" -- Call into compiled stub Atom nextFunc <- do case lastArg of True -> return $ Atom "applyWrapper" -- Use wrapper to call into 'apply' _ -> _gensym "applyNextArg" -- Next func argument to execute...- _comp <- mcompile env a $ CompileOptions stubFunc False False Nothing+ _comp <- mcompile env a $ CompileOptions stubFunc thisFuncUseValue False Nothing + -- inline function?+ fnc <- case maybeFnc of+ Just fncName -> compileInlineVar env fncName "value"+ _ -> return $ AstValue ""+ -- Flag below means that the expression's value matters, add it to args f <- if thisFuncUseValue then return $ AstValue $ thisFunc ++ " env cont value (Just args) = do " else return $ AstValue $ thisFunc ++ " env cont _ (Just args) = do " c <- do let nextCont' = case (lastArg, coptsNext) of- (True, Just fnextExpr) -> "(makeCPS env cont " ++ fnextExpr ++ ")"+ (True, Just fnextExpr) -> "(makeCPSWArgs env cont " ++ fnextExpr ++ " [])" _ -> "cont"+ let literalArgs = asts2Str asLiterals+ let argsCode = case thisFuncUseValue of+ True -> " $ args ++ [value] ++ " ++ literalArgs ++ ") " + False -> " $ args ++ " ++ literalArgs ++ ") "+ if thisFuncUseValue- then return $ AstValue $ " continueEval env (makeCPS env (makeCPSWArgs env " ++ nextCont' ++ " " ++- nextFunc ++ " $ args ++ [value]) " ++ stubFunc ++ ") $ Nil\"\"" - else return $ AstValue $ " continueEval env (makeCPS env (makeCPSWArgs env " ++ nextCont' ++ " " ++- nextFunc ++ " args) " ++ stubFunc ++ ") $ Nil\"\"" + then return $ AstValue $ " continueEval env (makeCPSWArgs env (makeCPSWArgs env " ++ nextCont' ++ " " +++ nextFunc ++ argsCode ++ stubFunc ++ " []) (Nil \"\") " + else return $ AstValue $ " continueEval env (makeCPSWArgs env (makeCPSWArgs env " ++ nextCont' ++ " " +++ nextFunc ++ argsCode ++ stubFunc ++ " []) $ Nil\"\"" rest <- case lastArg of True -> return [] -- Using apply wrapper, so no more code- _ -> compileArgs nextFunc True as -- True indicates nextFunc needs to use value arg passed into it- return $ [ f, c] ++ _comp ++ rest+ _ -> compileArgs nextFunc True Nothing asRest -- True indicates nextFunc needs to use value arg passed into it+ return $ [ f, fnc, c] ++ _comp ++ rest _ -> throwError $ TypeMismatch "nonempty list" $ List args @@ -1176,3 +1212,28 @@ collectLiterals, collectLiteralsAndVars :: [LispVal] -> (Maybe [LispVal]) collectLiteralsAndVars args = _collectLiterals args [] True collectLiterals args = _collectLiterals args [] False++-- Take as many literals as possible from the given list, and+-- return those literals and the rest of the list+takeLiterals :: LispVal -> [LispVal] -> ([LispVal], [LispVal])+takeLiterals (List _) ls = (ls, [])+takeLiterals _ ls' = do+ loop ls' []+ where+ loop (l : ls) acc = do+ if isLiteral l+ then loop ls (l : acc)+ else ((l:ls), acc)+ loop [] acc = ([], Data.List.reverse acc)++ isLiteral (List _) = False+ isLiteral (Atom _) = False+ isLiteral _ = True++-- Compile variable as a stand-alone line of code+compileInlineVar :: Env -> String -> String -> IOThrowsError HaskAST+compileInlineVar env a hsName = do+ isDefined <- liftIO $ isRecBound env a+ case isDefined of+ True -> return $ AstValue $ " " ++ hsName ++ " <- getRTVar env \"" ++ a ++ "\""+ False -> throwError $ UnboundVar "Variable is not defined" a
hs-src/Language/Scheme/Compiler/Libraries.hs view
@@ -177,7 +177,7 @@ AstValue $ " _ <- defineVar newEnv \"" ++ moduleRuntimeVar ++ "\" $ Pointer \"" ++ moduleRuntimeVar ++ "\" env", AstValue $ " _ <- " ++ symStartLoadNewEnv ++ - " newEnv (makeNullContinuation newEnv) (LispEnv env) []",+ " newEnv (makeNullContinuation newEnv) (LispEnv env) (Just [])", -- Save loaded module into runtime memory in case -- it gets included somewhere else later on AstValue $ " _ <- evalLisp env $ List [Atom \"hash-table-set!\", Atom \"" ++
hs-src/Language/Scheme/Compiler/Types.hs view
@@ -101,7 +101,7 @@ -> 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+ AstValue $ indentation ++ " continueEval env (makeCPSWArgs env cont " ++ nextFunc ++ " []) " ++ var createAstCont (CompileOptions _ _ _ Nothing) var indentation = do AstValue $ indentation ++ " continueEval env cont " ++ var @@ -124,9 +124,10 @@ showValAST :: HaskAST -> String showValAST (AstAssignM var val) = " " ++ var ++ " <- " ++ show val showValAST (AstFunction name args code) = do+ let typeSig = "\n" ++ name ++ " :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal " let fheader = "\n" ++ name ++ args ++ " = do " let fbody = unwords . map (\x -> "\n" ++ x ) $ map showValAST code- fheader ++ fbody + typeSig ++ fheader ++ fbody showValAST (AstValue v) = v showValAST (AstContinuation nextFunc args) = " continueEval env (makeCPSWArgs env cont " ++ @@ -220,7 +221,7 @@ "7" -> [] _ -> [ "exec55_3 env cont _ _ = do " , " liftIO $ registerExtensions env getDataFileName' "- , " continueEval env (makeCPS env cont exec) (Nil \"\")"]+ , " continueEval env (makeCPSWArgs env cont exec []) (Nil \"\")"] [ " " , "-- |Get variable at runtime " , "getRTVar env var = do " @@ -255,6 +256,6 @@ , " " , "hsInit env cont _ _ = do " , " _ <- defineVar env \"" ++ moduleRuntimeVar ++ "\" $ HashTable $ Data.Map.fromList [] "- , " run env cont (Nil \"\") []"+ , " run env cont (Nil \"\") (Just [])" , " "]
hs-src/Language/Scheme/Core.hs view
@@ -69,7 +69,7 @@ -- |husk version number version :: String-version = "3.15.2"+version = "3.16" -- |A utility function to display the husk console banner showBanner :: IO ()@@ -982,7 +982,7 @@ else (liftIO $ extendEnv aclosure $ zip (map ((,) varNamespace) aparams) args) >>= bindVarArgs avarargs >>= (evalBody abody) where remainingArgs = drop (length aparams) args num = toInteger . length- evalBody evBody env = evBody env cont (Nil "") Nothing + evalBody evBody env = evBody env cont (Nil "") (Just []) {- TODO: may need to handle cases from Func, such as dynamic winders case cont of Continuation _ (Just (SchemeBody cBody)) (Just cCont) _ cDynWind -> if length cBody == 0@@ -1162,7 +1162,8 @@ -- evalfuncExitSuccess, evalfuncExitFail, evalfuncApply, evalfuncDynamicWind, evalfuncEval, evalfuncLoad, evalfuncCallCC, evalfuncCallWValues,- evalfuncMakeEnv, evalfuncNullEnv, evalfuncInteractionEnv, evalfuncImport :: [LispVal] -> IOThrowsError LispVal+ evalfuncMakeEnv, evalfuncNullEnv, evalfuncUseParentEnv,+ evalfuncInteractionEnv, evalfuncImport :: [LispVal] -> IOThrowsError LispVal {- - A (somewhat) simplified implementation of dynamic-wind@@ -1240,6 +1241,13 @@ continueEval env cont $ LispEnv env evalfuncInteractionEnv _ = throwError $ InternalError "" +evalfuncUseParentEnv ((Continuation env a b c d) : _) = do+ let parEnv = case parentEnv env of+ Just env' -> env'+ Nothing -> env+ continueEval parEnv (Continuation parEnv a b c d) $ LispEnv parEnv+evalfuncUseParentEnv _ = throwError $ InternalError ""+ evalfuncImport [ cont@(Continuation env a b c d), toEnv,@@ -1377,6 +1385,8 @@ , ("%import", evalfuncImport) , ("%bootstrap-import", bootstrapImport) #endif+ , ("%husk-switch-to-parent-environment", evalfuncUseParentEnv)+ , ("exit-fail", evalfuncExitFail) , ("exit-success", evalfuncExitSuccess) ]
hs-src/Language/Scheme/Environments.hs view
@@ -26,10 +26,16 @@ -- |Primitive functions that execute within the IO monad ioPrimitives :: [(String, [LispVal] -> IOThrowsError LispVal)]-ioPrimitives = [("open-input-file", makePort openFile ReadMode),+ioPrimitives = [("open-input-file", makePort openFile ReadMode ), ("open-binary-input-file", makePort openBinaryFile ReadMode), ("open-output-file", makePort openFile WriteMode), ("open-binary-output-file", makePort openBinaryFile WriteMode),+ ("open-output-string", openOutputString),+ ("open-input-string", openInputString),+ ("get-output-string", getOutputString),+ ("open-output-bytevector", openOutputByteVector),+ ("open-input-bytevector", openInputByteVector),+ ("get-output-bytevector", getOutputByteVector), ("close-port", closePort), ("close-input-port", closePort), ("close-output-port", closePort),@@ -59,10 +65,12 @@ ("read-line", readProc False), ("read-char", readCharProc hGetChar), ("read-bytevector", readByteVector),+ ("read-string", readString), ("peek-char", readCharProc hLookAhead), ("write", writeProc (\ port obj -> hPrint port obj)), ("write-char", writeCharProc), ("write-bytevector", writeByteVector),+ ("write-string", writeString), ("display", writeProc (\ port obj -> do case obj of String str -> hPutStr port str
hs-src/Language/Scheme/Primitives.hs view
@@ -113,6 +113,13 @@ -- ** Input / Output , makePort + , makeBufferPort+ , openInputString+ , openOutputString+ , getOutputString+ , openInputByteVector+ , openOutputByteVector+ , getOutputByteVector , closePort , flushOutputPort , currentOutputPort @@ -127,9 +134,11 @@ , readProc , readCharProc , readByteVector+ , readString , writeProc , writeCharProc , writeByteVector+ , writeString , readContents , load , readAll@@ -155,6 +164,7 @@ import qualified Data.ByteString.UTF8 as BSU import Data.Char hiding (isSymbol) import Data.Array+import qualified Data.Knob as DK --import qualified Data.List as DL import qualified Data.Map import qualified Data.Time.Clock.POSIX@@ -192,11 +202,75 @@ -> IOMode -> [LispVal] -> IOThrowsError LispVal-makePort openFnc mode [String filename] = liftM Port $ liftIO $ openFnc filename mode+makePort openFnc mode [String filename] = do+ h <- liftIO $ openFnc filename mode+ return $ Port h Nothing makePort fnc mode [p@(Pointer _ _)] = recDerefPtrs p >>= box >>= makePort fnc mode makePort _ _ [] = throwError $ NumArgs (Just 1) [] makePort _ _ args@(_ : _) = throwError $ NumArgs (Just 1) args +-- |Create an memory-backed port+makeBufferPort :: Maybe LispVal -> IOThrowsError LispVal+makeBufferPort buf = do+ let mode = case buf of+ Nothing -> WriteMode+ _ -> ReadMode+ bs <- case buf of+ Just (String s)-> return $ BSU.fromString s+ Just (ByteVector bv)-> return bv+ Just err -> throwError $ TypeMismatch "string or bytevector" err+ Nothing -> return $ BS.pack []+ k <- DK.newKnob bs+ h <- liftIO $ DK.newFileHandle k "temp.buf" mode+ return $ Port h (Just k)++-- |Read byte buffer from a given port+getBufferFromPort :: LispVal -> IOThrowsError BSU.ByteString+getBufferFromPort (Port h (Just k)) = do+ _ <- liftIO $ hFlush h+ DK.getContents k+getBufferFromPort args = do+ throwError $ TypeMismatch "output-port" args++-- |Create a new input string buffer+openInputString :: [LispVal] -> IOThrowsError LispVal+openInputString [buf@(String _)] = makeBufferPort (Just buf)+openInputString args = if length args == 2+ then throwError $ TypeMismatch "(string)" $ List args+ else throwError $ NumArgs (Just 1) args++-- |Create a new output string buffer+openOutputString :: [LispVal] -> IOThrowsError LispVal+openOutputString _ = makeBufferPort Nothing++-- |Create a new input bytevector buffer+openInputByteVector :: [LispVal] -> IOThrowsError LispVal+openInputByteVector [buf@(ByteVector _)] = makeBufferPort (Just buf)+openInputByteVector args = if length args == 2+ then throwError $ TypeMismatch "(bytevector)" $ List args+ else throwError $ NumArgs (Just 1) args++-- |Create a new output bytevector buffer+openOutputByteVector :: [LispVal] -> IOThrowsError LispVal+openOutputByteVector _ = makeBufferPort Nothing+++-- |Get string written to string-output-port+getOutputString :: [LispVal] -> IOThrowsError LispVal+getOutputString [p@(Port _ _)] = do+ bytes <- getBufferFromPort p+ return $ String $ BSU.toString bytes +getOutputString args = do+ throwError $ TypeMismatch "output-port" $ List args++-- |Get bytevector written to bytevector-output-port+getOutputByteVector :: [LispVal] -> IOThrowsError LispVal+getOutputByteVector [p@(Port _ _)] = do+ bytes <- getBufferFromPort p+ return $ ByteVector bytes +getOutputByteVector args = do+ throwError $ TypeMismatch "output-port" $ List args+ -- |Close the given port -- -- Arguments:@@ -206,7 +280,7 @@ -- Returns: Bool - True if the port was closed, false otherwise -- closePort :: [LispVal] -> IOThrowsError LispVal-closePort [Port port] = liftIO $ hClose port >> (return $ Bool True)+closePort [Port port _] = liftIO $ hClose port >> (return $ Bool True) closePort _ = return $ Bool False @@ -222,7 +296,7 @@ -- Returns: Port -- currentInputPort :: [LispVal] -> IOThrowsError LispVal-currentInputPort _ = return $ Port stdin+currentInputPort _ = return $ Port stdin Nothing -- |Return the current input port -- -- LispVal Arguments: (None)@@ -230,12 +304,12 @@ -- Returns: Port -- currentOutputPort :: [LispVal] -> IOThrowsError LispVal-currentOutputPort _ = return $ Port stdout+currentOutputPort _ = return $ Port stdout Nothing -- | Flush the given output port flushOutputPort :: [LispVal] -> IOThrowsError LispVal flushOutputPort [] = liftIO $ hFlush stdout >> (return $ Bool True)-flushOutputPort [Port port] = liftIO $ hFlush port >> (return $ Bool True)+flushOutputPort [Port port _] = liftIO $ hFlush port >> (return $ Bool True) flushOutputPort _ = return $ Bool False -- | Determine if the given port is a text port.@@ -246,7 +320,7 @@ -- -- Returns: Bool isTextPort :: [LispVal] -> IOThrowsError LispVal-isTextPort [Port port] = do+isTextPort [Port port _] = do val <- liftIO $ isTextPort' port return $ Bool val isTextPort _ = return $ Bool False@@ -259,7 +333,7 @@ -- -- Returns: Bool isBinaryPort :: [LispVal] -> IOThrowsError LispVal-isBinaryPort [Port port] = do+isBinaryPort [Port port _] = do val <- liftIO $ isTextPort' port return $ Bool $ not val isBinaryPort _ = return $ Bool False@@ -280,7 +354,7 @@ -- -- Returns: Bool isInputPortOpen :: [LispVal] -> IOThrowsError LispVal-isInputPortOpen [Port port] = do+isInputPortOpen [Port port _] = do r <- liftIO $ hIsReadable port o <- liftIO $ hIsOpen port return $ Bool $ r && o@@ -294,7 +368,7 @@ -- -- Returns: Bool isOutputPortOpen :: [LispVal] -> IOThrowsError LispVal-isOutputPortOpen [Port port] = do+isOutputPortOpen [Port port _] = do w <- liftIO $ hIsWritable port o <- liftIO $ hIsOpen port return $ Bool $ w && o@@ -309,7 +383,7 @@ -- Returns: Bool - True if an input port, false otherwise -- isInputPort :: [LispVal] -> IOThrowsError LispVal-isInputPort [Port port] = liftM Bool $ liftIO $ hIsReadable port+isInputPort [Port port _] = liftM Bool $ liftIO $ hIsReadable port isInputPort _ = return $ Bool False -- |Determine if the given objects is an output port@@ -321,7 +395,7 @@ -- Returns: Bool - True if an output port, false otherwise -- isOutputPort :: [LispVal] -> IOThrowsError LispVal-isOutputPort [Port port] = liftM Bool $ liftIO $ hIsWritable port+isOutputPort [Port port _] = liftM Bool $ liftIO $ hIsWritable port isOutputPort _ = return $ Bool False -- |Determine if a character is ready on the port@@ -333,7 +407,7 @@ -- Returns: Bool -- isCharReady :: [LispVal] -> IOThrowsError LispVal-isCharReady [Port port] = do --liftM Bool $ liftIO $ hReady port+isCharReady [Port port _] = do --liftM Bool $ liftIO $ hReady port result <- liftIO $ try' (liftIO $ hReady port) case result of Left e -> if isEOFError e@@ -351,8 +425,8 @@ -- Returns: LispVal -- readProc :: Bool -> [LispVal] -> IOThrowsError LispVal-readProc mode [] = readProc mode [Port stdin]-readProc mode [Port port] = do+readProc mode [] = readProc mode [Port stdin Nothing]+readProc mode [Port port _] = do input <- liftIO $ try' (liftIO $ hGetLine port) case input of Left e -> if isEOFError e@@ -374,8 +448,8 @@ -- Returns: Char -- readCharProc :: (Handle -> IO Char) -> [LispVal] -> IOThrowsError LispVal-readCharProc func [] = readCharProc func [Port stdin]-readCharProc func [Port port] = do+readCharProc func [] = readCharProc func [Port stdin Nothing]+readCharProc func [Port port _] = do liftIO $ hSetBuffering port NoBuffering input <- liftIO $ try' (liftIO $ func port) liftIO $ hSetBuffering port LineBuffering@@ -396,7 +470,22 @@ -- -- Returns: ByteVector readByteVector :: [LispVal] -> IOThrowsError LispVal-readByteVector [Number n, Port port] = do+readByteVector args = readBuffer args (\ inBytes -> ByteVector inBytes)++-- | Read a string from the given port+--+-- Arguments+--+-- * Number - Number of bytes to read+-- * Port - Port to read from+--+-- Returns: String+readString :: [LispVal] -> IOThrowsError LispVal+readString args = readBuffer args (\ inBytes -> String $ BSU.toString inBytes)++-- |Helper function to read n bytes from a port into a buffer+readBuffer :: [LispVal] -> (BSU.ByteString -> LispVal) -> IOThrowsError LispVal+readBuffer [Number n, Port port _] rvfnc = do input <- liftIO $ try' (liftIO $ BS.hGet port $ fromInteger n) case input of Left e -> if isEOFError e@@ -405,10 +494,10 @@ Right inBytes -> do if BS.null inBytes then return $ EOF- else return $ ByteVector inBytes-readByteVector args = if length args == 2- then throwError $ TypeMismatch "(k port)" $ List args- else throwError $ NumArgs (Just 2) args+ else return $ rvfnc inBytes+readBuffer args _ = if length args == 2+ then throwError $ TypeMismatch "(k port)" $ List args+ else throwError $ NumArgs (Just 2) args -- |Write to the given port --@@ -427,8 +516,8 @@ -> [LispVal] -> ErrorT LispError IO LispVal writeProc func [obj] = do dobj <- recDerefPtrs obj -- Last opportunity to do this before writing- writeProc func [dobj, Port stdout]-writeProc func [obj, Port port] = do+ writeProc func [dobj, Port stdout Nothing]+writeProc func [obj, Port port _] = do dobj <- recDerefPtrs obj -- Last opportunity to do this before writing output <- liftIO $ try' (liftIO $ func port dobj) case output of@@ -449,8 +538,8 @@ -- Returns: (None) -- writeCharProc :: [LispVal] -> IOThrowsError LispVal-writeCharProc [obj] = writeCharProc [obj, Port stdout]-writeCharProc [obj@(Char _), Port port] = do+writeCharProc [obj] = writeCharProc [obj, Port stdout Nothing]+writeCharProc [obj@(Char _), Port port _] = do output <- liftIO $ try' (liftIO $ (hPutStr port $ show obj)) case output of Left _ -> throwError $ Default "I/O error writing to port"@@ -468,13 +557,36 @@ -- -- Returns: (unspecified) writeByteVector :: [LispVal] -> IOThrowsError LispVal-writeByteVector [obj, Port port] = do- ByteVector bs <- recDerefPtrs obj -- Last opportunity to do this before writing+writeByteVector args = writeBuffer args bv2b+ where+ bv2b obj = do+ ByteVector bs <- recDerefPtrs obj -- Last opportunity to do this before writing+ return bs++-- | Write a string to the given port+--+-- Arguments+--+-- * String+-- * Port+--+-- Returns: (unspecified)+writeString :: [LispVal] -> IOThrowsError LispVal+writeString args = writeBuffer args str2b+ where+ str2b obj = do+ String str <- recDerefPtrs obj -- Last opportunity to do this before writing+ return $ BSU.fromString str++-- |Helper function to write buffer-based data to output port+writeBuffer :: [LispVal] -> (LispVal -> IOThrowsError BSU.ByteString) -> IOThrowsError LispVal+writeBuffer [obj, Port port _] getBS = do+ bs <- getBS obj output <- liftIO $ try' (liftIO $ BS.hPut port bs) case output of Left _ -> throwError $ Default "I/O error writing to port" Right _ -> return $ Nil ""-writeByteVector other = +writeBuffer other _ = if length other == 2 then throwError $ TypeMismatch "(bytevector port)" $ List other else throwError $ NumArgs (Just 2) other@@ -706,12 +818,13 @@ -- fall back to the normal equality comparison eq :: [LispVal] -> IOThrowsError LispVal eq [(Pointer pA envA), (Pointer pB envB)] = do- if pA == pB - then do- refA <- getNamespacedRef envA varNamespace pA- refB <- getNamespacedRef envB varNamespace pB- return $ Bool $ refA == refB- else return $ Bool False+ return $ Bool $ (pA == pB) && ((bindings envA) == (bindings envB))+-- if pA == pB +-- then do+-- refA <- getNamespacedRef envA varNamespace pA+-- refB <- getNamespacedRef envB varNamespace pB+-- return $ Bool $ refA == refB+-- else return $ Bool False eq args = recDerefToFnc eqv args -- | Recursively compare two LispVals for equality
hs-src/Language/Scheme/Types.hs view
@@ -100,6 +100,7 @@ import Data.Array import qualified Data.ByteString as BS import Data.Dynamic+import qualified Data.Knob as DK import qualified Data.List as DL import Data.IORef import qualified Data.Map@@ -233,7 +234,7 @@ -- ^Pointer to an environment variable. | Opaque Dynamic -- ^Opaque Haskell value.- | Port Handle+ | Port Handle (Maybe DK.Knob) -- ^I/O port | Continuation { contClosure :: Env -- Environment of the continuation , currentCont :: (Maybe DeferredCode) -- Code of current continuation@@ -459,7 +460,7 @@ (case varargs of Nothing -> "" Just arg -> " . " ++ arg) ++ ") ...)"-showVal (Port _) = "<IO port>"+showVal (Port _ _) = "<IO port>" showVal (IOFunc _) = "<IO primitive>" showVal (CustFunc _) = "<custom primitive>" showVal (EvalFunc _) = "<procedure>"
husk-scheme.cabal view
@@ -1,5 +1,5 @@ Name: husk-scheme-Version: 3.15.2+Version: 3.16 Synopsis: R5RS Scheme interpreter, compiler, and library. Description: <<https://github.com/justinethier/husk-scheme/raw/master/docs/husk-scheme.png>>@@ -69,7 +69,7 @@ default: True Library- Build-Depends: base >= 2.0 && < 5, array, containers, haskeline, transformers, mtl, parsec, directory, bytestring, utf8-string, time, process+ Build-Depends: base >= 2.0 && < 5, array, containers, haskeline, transformers, mtl, parsec, directory, bytestring, utf8-string, time, process, knob Extensions: ExistentialQuantification Hs-Source-Dirs: hs-src Exposed-Modules: Language.Scheme.Core
lib/core.scm view
@@ -76,7 +76,9 @@ (define-syntax begin (syntax-rules () ((begin exp ...)- ((lambda () exp ...)))))+ ((lambda () + (%husk-switch-to-parent-environment)+ exp ...))))) (define-syntax include (syntax-rules ()@@ -86,15 +88,10 @@ (load file2) ...)))) ;-; ; 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:@@ -600,6 +597,19 @@ (every* (cdr l))) (else #f))))++;; Simplified version of filter from SRFI 1+(define (filter pred lis)+ (let recur ((lis lis)) + (if (null? lis) + lis+ (let ((head (car lis))+ (tail (cdr lis)))+ (if (pred head)+ (let ((new-tail (recur tail)))+ (if (eq? tail new-tail) lis+ (cons head new-tail)))+ (recur tail)))))) ;; Macros from r7rs (define-syntax when
lib/modules.scm view
@@ -25,6 +25,7 @@ (define (identifier->symbol s) s) (define *this-module* '())+(define *loading* '()) (define (make-module exports env meta) (vector exports env meta #f)) (define (%module-exports mod) (vector-ref mod 0))@@ -180,9 +181,13 @@ (else (error "couldn't find include" f))))) files)) ;; catch cyclic references- (module-meta-data-set!- mod- `((error "module attempted to reference itself while loading" ,name)))+ (if (member name *loading*)+ (error "module attempted to reference itself while loading" name)+ ;(write `(cyclic reference ,name))+ (set! *loading* (cons name *loading*)))+;; (module-meta-data-set!+;; mod+;; `((error "module attempted to reference itself while loading" ,name))) (for-each (lambda (x) (case (and (pair? x) (car x))@@ -212,7 +217,8 @@ ((error) (apply error (cdr x))))) meta)- (module-meta-data-set! mod meta)+ (set! *loading* (filter (lambda (n) (equal? n name)) *loading*))+;; (module-meta-data-set! mod meta) ;(warn-undefs env #f) ; JAE - commented this out (TODO) env)) @@ -229,7 +235,14 @@ (define (load-module name) (let ((mod (find-module name))) (if (and mod (not (module-env mod)))- (module-env-set! mod (eval-module name mod)))+ ((lambda ()+ (module-env-set! mod (eval-module name mod))+;(write `(DEBUG ,name before set modules is ,*modules*))+ (set! *modules* ;; Only eval each module once+ (cons (cons name mod)+ (filter (lambda (m) (not (equal? (car m) name))) *modules*)))+;(write `(DEBUG ,name after set modules is ,*modules*))+))) mod)) ;TODO: see below:@@ -305,11 +318,7 @@ (let lp ((ls (cdr expr)) (res '())) (cond ((null? ls)- ; JAE - Using expanded version of begin because there were- ; problems with using the following line from chibi.- ; This may highlight a problem in husk, but for the- ; purposes of this file we are moving on...- ;+ ; Issues with 2 versions of begin here, so just expand manually ;(cons (rename 'orig-begin) (reverse res))) (cons (cons
lib/scheme/base.sld view
@@ -254,5 +254,6 @@ ;write-bytevector ;write-string ;write-u8+ %husk-switch-to-parent-environment ) (import (scheme)))