diff --git a/ChangeLog.markdown b/ChangeLog.markdown --- a/ChangeLog.markdown +++ b/ChangeLog.markdown @@ -1,3 +1,41 @@ +v3.8 +-------- + +This release introduces several performance improvements: + +- Macro expansions are now cached, significantly improving performance when repeatedly calling a function containing macros. +- A `Pointer` type was added in version 3.6 as part of the changes to enhance the variable storage model. Unfortunately the initial implementation naively checked for pointers prior to calling into any Haskell function. This release eliminates those inefficiencies by allowing primitive functions to deal with the Pointer type directly, instead of attempting to convert values before passing them to primitive functions. +- Restructured code in the Macro module to eliminate redundant calls to `Data.Map.lookup`. + +The example game of life program `examples/game-of-life/life.scm` demonstrates these performance improvements, as it now runs over 4.5 times faster than in the previous release. + +This release also adds the following library from R7RS: + +- `(scheme r5rs)` - Exposes the full husk R5RS environment + +And, R5RS versions of the scheme libraries have been relocated to underneath `(scheme r5rs)`. Each of these libraries exposes a husk subset of the functions recommended by R7RS: + +- `(scheme r5rs base)` +- `(scheme r5rs char)` +- `(scheme r5rs complex)` +- `(scheme r5rs cxr)` +- `(scheme r5rs eval)` +- `(scheme r5rs file)` +- `(scheme r5rs inexact)` +- `(scheme r5rs lazy)` +- `(scheme r5rs load)` +- `(scheme r5rs read)` +- `(scheme r5rs write)` + +Changes to the Haskell API: + +- Introduced a new type of function, `CustFunc`, which is now the recommended way to define your own Haskell functions when using the Haskell API. This type allows you to avoid having to handle Pointer types directly in your Haskell code. If you know what you are doing, though, you can handle Pointer types and avoid the overhead of checking for pointers prior to calling into your function code. +- Moved `runIOThrows` into Core, and removed obsolete functions `trapError` and `extractValue`. + +Bug fixes: + +- Updated `map` and `for-each` to accept multiple list arguments, per R5RS. + v3.7 -------- diff --git a/hs-src/Compiler/huskc.hs b/hs-src/Compiler/huskc.hs --- a/hs-src/Compiler/huskc.hs +++ b/hs-src/Compiler/huskc.hs @@ -138,7 +138,7 @@ env <- Language.Scheme.Core.primitiveBindings stdlib <- getDataFileName "lib/stdlib.scm" srfi55 <- getDataFileName "lib/srfi/srfi-55.scm" -- (require-extension) - result <- (runIOThrows $ liftM show $ compileSchemeFile env stdlib srfi55 inFile) + result <- (Language.Scheme.Core.runIOThrows $ liftM show $ compileSchemeFile env stdlib srfi55 inFile) case result of Just errMsg -> putStrLn errMsg _ -> compileHaskellFile outExec dynamic extraArgs @@ -159,7 +159,7 @@ execC <- compileLisp env filename "exec" Nothing -- Append any additional import modules - List imports <- getNamespacedVar env "internal" "imports" + List imports <- getNamespacedVar env 't' {-"internal"-} "imports" let moreHeaderImports = map conv imports outH <- liftIO $ openFile "_tmp.hs" WriteMode diff --git a/hs-src/Interpreter/shell.hs b/hs-src/Interpreter/shell.hs --- a/hs-src/Interpreter/shell.hs +++ b/hs-src/Interpreter/shell.hs @@ -70,10 +70,11 @@ putStrLn " Options may be any of the following:" putStrLn "" putStrLn " -h -? --help Display this information" - putStrLn " -r --revision Specify the scheme revision to use:" - putStrLn "" - putStrLn " 5 - r5rs (default)" - putStrLn " 7 - r7rs small" +-- TODO: specify scheme rev via command line +-- putStrLn " -r --revision Specify the scheme revision to use:" +-- putStrLn "" +-- putStrLn " 5 - r5rs (default)" +-- putStrLn " 7 - r7rs small" putStrLn "" exitWith ExitSuccess diff --git a/hs-src/Language/Scheme/Compiler.hs b/hs-src/Language/Scheme/Compiler.hs --- a/hs-src/Language/Scheme/Compiler.hs +++ b/hs-src/Language/Scheme/Compiler.hs @@ -170,7 +170,7 @@ -- and the imports are explicitly added later on... initializeCompiler :: Env -> IOThrowsError [HaskAST] initializeCompiler env = do - _ <- defineNamespacedVar env "internal" "imports" $ List [] + _ <- defineNamespacedVar env 't' {-"internal"-} "imports" $ List [] return [] @@ -579,11 +579,11 @@ symDoSet ++ " e c obj (Just [List (l : _)]) = do\n" ++ " l' <- recDerefPtrs l\n" ++ " obj' <- recDerefPtrs obj\n" ++ - " (liftThrows $ cons [l', obj']) >>= updateObject e \"" ++ var ++ "\" >>= " ++ finalContinuation ++ + " (cons [l', obj']) >>= updateObject e \"" ++ var ++ "\" >>= " ++ finalContinuation ++ symDoSet ++ " e c obj (Just [DottedList (l : _) _]) = do\n" ++ " l' <- recDerefPtrs l\n" ++ " obj' <- recDerefPtrs obj\n" ++ - " (liftThrows $ cons [l', obj']) >>= updateObject e \"" ++ var ++ "\" >>= " ++ finalContinuation ++ + " (cons [l', obj']) >>= updateObject e \"" ++ var ++ "\" >>= " ++ finalContinuation ++ symDoSet ++ " _ _ _ _ = throwError $ InternalError \"Unexpected argument to " ++ symDoSet ++ "\"\n" -- Return a list of all the compiled code @@ -718,9 +718,9 @@ -- Atom symLoadFFI <- _gensym "loadFFI" -- Only append module again if it is not already in the list - List l <- getNamespacedVar env "internal" "imports" + List l <- getNamespacedVar env 't' {-"internal"-} "imports" _ <- if not ((String moduleName) `elem` l) - then setNamespacedVar env "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 diff --git a/hs-src/Language/Scheme/Core.hs b/hs-src/Language/Scheme/Core.hs --- a/hs-src/Language/Scheme/Core.hs +++ b/hs-src/Language/Scheme/Core.hs @@ -21,6 +21,8 @@ , evalAndPrint , apply , continueEval + , runIOThrows + , runIOThrowsREPL -- * Core data , primitiveBindings , r5rsEnv @@ -29,6 +31,7 @@ , getDataFileFullPath , registerExtensions , showBanner + , showLispError , substr , updateVector , updateByteVector @@ -57,7 +60,7 @@ -- |husk version number version :: String -version = "3.7" +version = "3.8" -- |A utility function to display the husk console banner showBanner :: IO () @@ -73,7 +76,6 @@ putStrLn " (c) 2010-2013 Justin Ethier " putStrLn $ " Version " ++ version ++ " " putStrLn " " - -- |Get the full path to a data file installed for husk getDataFileFullPath :: String -> IO String getDataFileFullPath s = PHS.getDataFileName s @@ -93,7 +95,43 @@ (escapeBackslashes filename) ++ "\")" return () +-- TODO: good news is I think this can be completely implemented in husk, no changes necessary to third party code. the bad news is that this guy needs to be called from the runIOThrows* code instead of show which means that code needs to be relocated (maybe to this module, if that is appropriate (not sure it is)... +-- |This is the recommended function to use to display a lisp error, instead +-- of just using show directly. +showLispError :: LispError -> IO String +showLispError (TypeMismatch str p@(Pointer _ e)) = do + lv' <- evalLisp' e p + case lv' of + Left _ -> showLispError $ TypeMismatch str $ Atom $ show p + Right val -> showLispError $ TypeMismatch str val +showLispError (BadSpecialForm str p@(Pointer _ e)) = do + lv' <- evalLisp' e p + case lv' of + Left _ -> showLispError $ BadSpecialForm str $ Atom $ show p + Right val -> showLispError $ BadSpecialForm str val +showLispError err = return $ show err + +-- |Execute an IO action and return result or an error message. +-- This is intended for use by a REPL, where a result is always +-- needed regardless of type. +runIOThrowsREPL :: IOThrowsError String -> IO String +runIOThrowsREPL action = do + runState <- runErrorT action + case runState of + Left err -> showLispError err + Right val -> return val + +-- |Execute an IO action and return error or Nothing if no error was thrown. +runIOThrows :: IOThrowsError String -> IO (Maybe String) +runIOThrows action = do + runState <- runErrorT action + case runState of + Left err -> do + disp <- showLispError err + return $ Just disp + Right _ -> return $ Nothing + {- |Evaluate a string containing Scheme code @ @@ -198,6 +236,9 @@ - continuation (if there is one), or we just return the result. Yes technically with - CPS you are supposed to keep calling into functions and never return, but in this case - when the computation is complete, you have to return something. + - + - NOTE: We use 'eval' below instead of 'meval' because macros are already expanded when + - a function is loaded the first time, so there is no need to test for this again here. -} continueEval _ (Continuation cEnv (Just (SchemeBody cBody)) (Just cCont) extraArgs dynWind) val = do -- case (trace ("cBody = " ++ show cBody) cBody) of @@ -208,8 +249,8 @@ -- Pass extra args along if last expression of a function, to support (call-with-values) continueEval nEnv (Continuation nEnv ncCont nnCont extraArgs nDynWind) val _ -> return (val) - [lv] -> meval cEnv (Continuation cEnv (Just (SchemeBody [])) (Just cCont) Nothing dynWind) lv - (lv : lvs) -> meval cEnv (Continuation cEnv (Just (SchemeBody lvs)) (Just cCont) Nothing dynWind) lv + [lv] -> eval cEnv (Continuation cEnv (Just (SchemeBody [])) (Just cCont) Nothing dynWind) lv + (lv : lvs) -> eval cEnv (Continuation cEnv (Just (SchemeBody lvs)) (Just cCont) Nothing dynWind) lv -- No current continuation, but a next cont is available; call into it continueEval _ (Continuation cEnv Nothing (Just cCont) _ _) val = continueEval cEnv cCont val @@ -257,6 +298,8 @@ eval env cont (Atom a) = do v <- getVar env a val <- return $ case v of +-- TODO: this flag may go away on this branch; it may +-- not be practical with Pointer used everywhere now #ifdef UsePointers List _ -> Pointer a env DottedList _ _ -> Pointer a env @@ -313,12 +356,10 @@ eval env cont args@(List [Atom "define-syntax", Atom newKeyword, Atom keyword]) = do - bound <- liftIO $ isNamespacedRecBound env macroNamespace keyword - if bound - then do - m <- getNamespacedVar env macroNamespace keyword - defineNamespacedVar env macroNamespace newKeyword m - else throwError $ TypeMismatch "macro" $ Atom keyword + bound <- getNamespacedVar' env macroNamespace keyword + case bound of + Just m -> defineNamespacedVar env macroNamespace newKeyword m + Nothing -> throwError $ TypeMismatch "macro" $ Atom keyword eval env cont args@(List [Atom "define-syntax", Atom keyword, (List [Atom "er-macro-transformer", @@ -413,38 +454,46 @@ if bound then prepareApply env cont args -- if is bound to a variable in this scope; call into it else do - -- Experimenting with macro expansion of body of function - -- ebody <- mapM (\ lisp -> Language.Scheme.Macro.macroEval env lisp apply) fbody - result <- (makeNormalFunc env fparams fbody >>= defineVar env var) + -- Cache macro expansions within function body + ebody <- mapM (\ lisp -> Language.Scheme.Macro.macroEval env lisp apply) fbody + result <- (makeNormalFunc env fparams ebody >>= defineVar env var) continueEval env cont result eval env cont args@(List (Atom "define" : DottedList (Atom var : fparams) varargs : fbody)) = do bound <- liftIO $ isRecBound env "define" if bound then prepareApply env cont args -- if is bound to a variable in this scope; call into it - else do result <- (makeVarargs varargs env fparams fbody >>= defineVar env var) - continueEval env cont result + else do + ebody <- mapM (\ lisp -> Language.Scheme.Macro.macroEval env lisp apply) fbody + result <- (makeVarargs varargs env fparams ebody >>= defineVar env var) + continueEval env cont result eval env cont args@(List (Atom "lambda" : List fparams : fbody)) = do bound <- liftIO $ isRecBound env "lambda" if bound then prepareApply env cont args -- if is bound to a variable in this scope; call into it - else do result <- makeNormalFunc env fparams fbody - continueEval env cont result + else do + ebody <- mapM (\ lisp -> Language.Scheme.Macro.macroEval env lisp apply) fbody + result <- makeNormalFunc env fparams ebody + continueEval env cont result eval env cont args@(List (Atom "lambda" : DottedList fparams varargs : fbody)) = do bound <- liftIO $ isRecBound env "lambda" if bound then prepareApply env cont args -- if is bound to a variable in this scope; call into it - else do result <- makeVarargs varargs env fparams fbody - continueEval env cont result + else do + ebody <- mapM (\ lisp -> Language.Scheme.Macro.macroEval env lisp apply) fbody + result <- makeVarargs varargs env fparams ebody + continueEval env cont result eval env cont args@(List (Atom "lambda" : varargs@(Atom _) : fbody)) = do bound <- liftIO $ isRecBound env "lambda" if bound then prepareApply env cont args -- if is bound to a variable in this scope; call into it - else do result <- makeVarargs varargs env [] fbody - continueEval env cont result + else do + ebody <- mapM (\ lisp -> Language.Scheme.Macro.macroEval env lisp apply) fbody + result <- makeVarargs varargs env [] ebody + continueEval env cont result eval env cont args@(List [Atom "string-set!", Atom var, i, character]) = do bound <- liftIO $ isRecBound env "string-set!" @@ -455,7 +504,7 @@ cpsStr :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsStr e c idx _ = do value <- getVar env var - derefValue <- recDerefPtrs value + derefValue <- derefPtr value meval e (makeCPSWArgs e c cpsSubStr $ [idx]) derefValue cpsSubStr :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal @@ -480,10 +529,12 @@ then prepareApply env cont args -- if is bound to a variable in this scope; call into it else do value <- getVar env var - derefValue <- recDerefPtrs value - continueEval env (makeCPS env cont cpsObj) derefValue + continueEval env (makeCPS env cont cpsObj) value where cpsObj :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal + cpsObj e c obj@(Pointer _ _) x = do + o <- derefPtr obj + cpsObj e c o x cpsObj _ _ obj@(List []) _ = throwError $ TypeMismatch "pair" obj cpsObj e c obj@(List (_ : _)) _ = meval e (makeCPSWArgs e c cpsSet $ [obj]) argObj cpsObj e c obj@(DottedList _ _) _ = meval e (makeCPSWArgs e c cpsSet $ [obj]) argObj @@ -510,7 +561,7 @@ then prepareApply env cont args -- if is bound to a variable in this scope; call into it else do value <- getVar env var - derefValue <- recDerefPtrs value --derefPtr value + derefValue <- derefPtr value continueEval env (makeCPS env cont cpsObj) derefValue where cpsObj :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal @@ -523,11 +574,11 @@ cpsSet e c obj (Just [List (l : _)]) = do l' <- recDerefPtrs l obj' <- recDerefPtrs obj - (liftThrows $ cons [l', obj']) >>= updateObject e var >>= continueEval e c + (cons [l', obj']) >>= updateObject e var >>= continueEval e c cpsSet e c obj (Just [DottedList (l : _) _]) = do l' <- recDerefPtrs l obj' <- recDerefPtrs obj - (liftThrows $ cons [l', obj']) >>= updateObject e var >>= continueEval e c + (cons [l', obj']) >>= updateObject e var >>= continueEval e c cpsSet _ _ _ _ = throwError $ InternalError "Unexpected argument to cpsSet" eval env cont args@(List [Atom "set-cdr!" , nonvar , _ ]) = do bound <- liftIO $ isRecBound env "set-cdr!" @@ -612,7 +663,7 @@ cpsH :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsH e c value (Just [key]) = do v <- getVar e var - derefVar <- recDerefPtrs v + derefVar <- derefPtr v meval e (makeCPSWArgs e c cpsEvalH $ [key, value]) derefVar cpsH _ _ _ _ = throwError $ InternalError "Invalid argument to cpsH" @@ -643,7 +694,7 @@ cpsH :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsH e c key _ = do value <- getVar e var - derefValue <- recDerefPtrs value + derefValue <- derefPtr value meval e (makeCPSWArgs e c cpsEvalH $ [key]) derefValue cpsEvalH :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal @@ -681,7 +732,7 @@ updateVector :: LispVal -> LispVal -> LispVal -> IOThrowsError LispVal updateVector (Vector vec) (Number idx) obj = return $ Vector $ vec // [(fromInteger idx, obj)] updateVector ptr@(Pointer _ _) i obj = do - vec <- recDerefPtrs ptr + vec <- derefPtr ptr updateVector vec i obj updateVector v _ _ = throwError $ TypeMismatch "vector" v @@ -695,7 +746,7 @@ return $ ByteVector $ BS.concat [h, BS.pack $ [fromInteger byte :: Word8], BS.tail t] badType -> throwError $ TypeMismatch "byte" badType updateByteVector ptr@(Pointer _ _) i obj = do - vec <- recDerefPtrs ptr + vec <- derefPtr ptr updateByteVector vec i obj updateByteVector v _ _ = throwError $ TypeMismatch "bytevector" v @@ -744,26 +795,32 @@ cpsApply :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal cpsApply e c _ _ = doApply e c doApply e c = do - -- TODO (?): List dargs <- recDerefPtrs $ List args -- Deref any pointers case (toInteger $ length args) of 0 -> throwError $ NumArgs (Just 1) [] 1 -> continueEval e c $ head args _ -> -- Pass along additional arguments, so they are available to (call-with-values) continueEval e (Continuation env ccont ncont (Just $ tail args) ndynwind) $ head args apply cont (IOFunc func) args = do + result <- func args + case cont of + Continuation cEnv _ _ _ _ -> continueEval cEnv cont result + _ -> return result +apply cont (CustFunc func) args = do List dargs <- recDerefPtrs $ List args -- Deref any pointers result <- func dargs case cont of Continuation cEnv _ _ _ _ -> continueEval cEnv cont result _ -> return result apply cont (EvalFunc func) args = do - {- An EvalFunc extends the evaluator so it needs access to the current continuation; - pass it as the first argument. -} - List dargs <- recDerefPtrs $ List args -- Deref any pointers - func (cont : dargs) + -- An EvalFunc extends the evaluator so it needs access to the current + -- continuation, so pass it as the first argument. + func (cont : args) apply cont (PrimitiveFunc func) args = do - List dargs <- recDerefPtrs $ List args -- Deref any pointers - result <- liftThrows $ func dargs +-- TODO: +-- how to report errors that could contain ptr args (perhaps a new error type?) +-- - any other complications? + --List dargs <- recDerefPtrs $ List args -- Deref any pointers + result <- liftThrows $ func args case cont of Continuation cEnv _ _ _ _ -> continueEval cEnv cont result _ -> return result @@ -865,7 +922,7 @@ _ <- evalLisp' env $ List [Atom "%bootstrap-import"] -- Load (r5rs base) _ <- evalString metaEnv - "(add-module! '(r5rs) (make-module #f (interaction-environment) '()))" + "(add-module! '(scheme r5rs) (make-module #f (interaction-environment) '()))" #endif return env @@ -934,8 +991,7 @@ List aLastElems -> do apply cont func $ (init args) ++ aLastElems Pointer pVar pEnv -> do - value <- recDerefPtrs aRev - applyArgs value + derefPtr aRev >>= applyArgs other -> throwError $ TypeMismatch "List" other evalfuncApply (_ : args) = throwError $ NumArgs (Just 2) args -- Skip over continuation argument evalfuncApply _ = throwError $ NumArgs (Just 2) [] @@ -971,14 +1027,18 @@ return $ LispEnv gp Just (Environment Nothing _ _ ) -> throwError $ InternalError "import into empty parent env" Nothing -> throwError $ InternalError "import into empty env" - case imports of + p@(Pointer _ _) -> do + -- TODO: need to do this in a safer way + List i <- derefPtr p -- Dangerous, but list is only expected obj + result <- moduleImport toEnv' fromEnv i + continueEval env cont result List i -> do result <- moduleImport toEnv' fromEnv i continueEval env cont result Bool False -> do -- Export everything newEnv <- liftIO $ importEnv toEnv' fromEnv - continueEval + continueEval env (Continuation env a b c d) (LispEnv newEnv) @@ -995,6 +1055,10 @@ continueEval env cont renv +evalfuncLoad (cont : p@(Pointer _ _) : lvs) = do + lv <- derefPtr p + evalfuncLoad (cont : lv : lvs) + evalfuncLoad [cont@(Continuation _ a b c d), String filename, LispEnv env] = do evalfuncLoad [Continuation env a b c d, String filename] @@ -1026,8 +1090,12 @@ -- -- FUTURE: consider allowing env to be specified, per R5RS -- -evalfuncEval [cont@(Continuation env _ _ _ _), val] = meval env cont val -evalfuncEval [cont@(Continuation _ _ _ _ _), val, LispEnv env] = meval env cont val +evalfuncEval [cont@(Continuation env _ _ _ _), val] = do + v <- derefPtr val -- Must deref ptrs for macro subsystem + meval env cont v +evalfuncEval [cont@(Continuation _ _ _ _ _), val, LispEnv env] = do + v <- derefPtr val -- Must deref ptrs for macro subsystem + meval env cont v evalfuncEval (_ : args) = throwError $ NumArgs (Just 1) args -- Skip over continuation argument evalfuncEval _ = throwError $ NumArgs (Just 1) [] @@ -1118,6 +1186,65 @@ String str -> hPutStr port str _ -> hPutStr port $ show obj)), + ("string=?", strBoolBinop (==)), + ("string?", strBoolBinop (>)), + ("string<=?", strBoolBinop (<=)), + ("string>=?", strBoolBinop (>=)), + ("string-ci=?", stringCIEquals), + ("string-ci?", stringCIBoolBinop (>)), + ("string-ci<=?", stringCIBoolBinop (<=)), + ("string-ci>=?", stringCIBoolBinop (>=)), + ("string->symbol", string2Symbol), + + ("car", car), + ("cdr", cdr), + ("cons", cons), + + -- TODO: these need to be rewritten to actually be in + -- the IO monad, tmpWrap is just temporary + ("eq?", tmpWrap eqv), + ("eqv?", tmpWrap eqv), + ("equal?", tmpWrap equal), + + ("pair?", isDottedList), + ("list?", unaryOp' isList), + ("vector?", unaryOp' isVector), + ("null?", isNull), + ("string?", isString), + + ("string-length", stringLength), + ("string-ref", stringRef), + ("substring", substring), + ("string-append", stringAppend), + ("string->number", stringToNumber), + ("string->list", stringToList), + ("list->string", listToString), + ("string-copy", stringCopy), + ("string->utf8", byteVectorStr2Utf), + + ("bytevector?", unaryOp' isByteVector), + ("bytevector-length", byteVectorLength), + ("bytevector-u8-ref", byteVectorRef), + ("bytevector-append", byteVectorAppend), + ("bytevector-copy", byteVectorCopy), + ("utf8->string", byteVectorUtf2Str), + + ("vector-length",wrapLeadObj vectorLength), + ("vector-ref", wrapLeadObj vectorRef), + ("vector->list", wrapLeadObj vectorToList), + ("list->vector", wrapLeadObj listToVector), + + ("hash-table?", wrapHashTbl isHashTbl), + ("hash-table-exists?",wrapHashTbl hashTblExists), + ("hash-table-ref", wrapHashTbl hashTblRef), + ("hash-table-size", wrapHashTbl hashTblSize), + ("hash-table->alist", wrapHashTbl hashTbl2List), + ("hash-table-keys", wrapHashTbl hashTblKeys), + ("hash-table-values", wrapHashTbl hashTblValues), + ("hash-table-copy", wrapHashTbl hashTblCopy), + -- From SRFI 96 ("file-exists?", fileExists), ("delete-file", deleteFile), @@ -1130,16 +1257,25 @@ ("find-module-file", findModuleFile), ("gensym", gensym)] +-- TODO: +-- This function is a temporary stopgap that will go +-- away before this branch is merged +tmpWrap :: ([LispVal] -> ThrowsError LispVal) -> [LispVal] -> IOThrowsError LispVal +tmpWrap fnc lvs = do + List result <- recDerefPtrs $ List lvs + liftThrows $ fnc result + printEnv' :: [LispVal] -> IOThrowsError LispVal printEnv' [LispEnv env] = do result <- liftIO $ printEnv env return $ String result +printEnv' [] = throwError $ NumArgs (Just 1) [] +printEnv' args = throwError $ TypeMismatch "env" $ List args exportsFromEnv' :: [LispVal] -> IOThrowsError LispVal exportsFromEnv' [LispEnv env] = do result <- liftIO $ exportsFromEnv env return $ List result ---exportsFromEnv' err = throwError $ Default $ "bad args: " ++ show err exportsFromEnv' err = return $ List [] {- "Pure" primitive functions -} @@ -1193,16 +1329,6 @@ ("&&", boolBoolBinop (&&)), ("||", boolBoolBinop (||)), - ("string=?", strBoolBinop (==)), - ("string?", strBoolBinop (>)), - ("string<=?", strBoolBinop (<=)), - ("string>=?", strBoolBinop (>=)), - ("string-ci=?", stringCIEquals), - ("string-ci?", stringCIBoolBinop (>)), - ("string-ci<=?", stringCIBoolBinop (<=)), - ("string-ci>=?", stringCIBoolBinop (>=)), ("char=?", charBoolBinop (==)), ("charstring", symbol2String), - ("string->symbol", string2Symbol), ("char?", isChar), - ("vector?", unaryOp isVector), ("make-vector", makeVector), ("vector", buildVector), - ("vector-length", vectorLength), - ("vector-ref", vectorRef), - ("vector->list", vectorToList), - ("list->vector", listToVector), - ("bytevector?", unaryOp isByteVector), ("make-bytevector", makeByteVector), ("bytevector", byteVector), - ("bytevector-length", byteVectorLength), - ("bytevector-u8-ref", byteVectorRef), - ("bytevector-append", byteVectorAppend), - ("bytevector-copy", byteVectorCopy), - ("utf8->string", byteVectorUtf2Str), - ("string->utf8", byteVectorStr2Utf), ("make-hash-table", hashTblMake), - ("hash-table?", isHashTbl), - ("hash-table-exists?", hashTblExists), - ("hash-table-ref", hashTblRef), - ("hash-table-size", hashTblSize), - ("hash-table->alist", hashTbl2List), - ("hash-table-keys", hashTblKeys), - ("hash-table-values", hashTblValues), - ("hash-table-copy", hashTblCopy), - - ("string?", isString), ("string", buildString), ("make-string", makeString), - ("string-length", stringLength), - ("string-ref", stringRef), - ("substring", substring), - ("string-append", stringAppend), - ("string->number", stringToNumber), - ("string->list", stringToList), - ("list->string", listToString), - ("string-copy", stringCopy), ("boolean?", isBoolean)] diff --git a/hs-src/Language/Scheme/Libraries.hs b/hs-src/Language/Scheme/Libraries.hs --- a/hs-src/Language/Scheme/Libraries.hs +++ b/hs-src/Language/Scheme/Libraries.hs @@ -27,11 +27,25 @@ findModuleFile :: [LispVal] -> IOThrowsError LispVal +findModuleFile [p@(Pointer _ _)] = recDerefPtrs p >>= box >>= findModuleFile findModuleFile [String file] -- Built-in modules --- TODO: does this work in Windows, since it uses the "wrong" type of slashes for that OS? - | file == "r5rs/base.sld" || + | file == "scheme/r5rs/base.sld" || + file == "scheme/r5rs/char.sld" || + file == "scheme/r5rs/complex.sld" || + file == "scheme/r5rs/cxr.sld" || + file == "scheme/r5rs/eval.sld" || + file == "scheme/r5rs/file.sld" || + file == "scheme/r5rs/inexact.sld" || + file == "scheme/r5rs/lazy.sld" || + file == "scheme/r5rs/load.sld" || + file == "scheme/r5rs/read.sld" || + file == "scheme/r5rs/write.sld" || file == "scheme/base.sld" || +-- TODO: scheme case-lambda (r7rs) +-- TODO: scheme process-context (r7rs) +-- TODO: scheme repl (r7rs) +-- TODO: scheme time (r7rs) file == "scheme/write.sld" = do path <- liftIO $ PHS.getDataFileName $ "lib/" ++ file return $ String path @@ -44,6 +58,9 @@ -> Env -- ^ Environment to import from -> [LispVal] -- ^ Identifiers to import -> IOThrowsError LispVal +moduleImport to from (p@(Pointer _ _) : is) = do + i <- derefPtr p + moduleImport to from (i : is) moduleImport to from (Atom i : is) = do _ <- divertBinding to from i i moduleImport to from is diff --git a/hs-src/Language/Scheme/Macro.hs b/hs-src/Language/Scheme/Macro.hs --- a/hs-src/Language/Scheme/Macro.hs +++ b/hs-src/Language/Scheme/Macro.hs @@ -109,11 +109,11 @@ -- mean to be used by the husk compiler. getDivertedVars :: Env -> IOThrowsError [LispVal] getDivertedVars env = do - List tmp <- getNamespacedVar env " " "diverted" + List tmp <- getNamespacedVar env ' ' "diverted" return tmp clearDivertedVars :: Env -> IOThrowsError LispVal -clearDivertedVars env = defineNamespacedVar env " " "diverted" $ List [] +clearDivertedVars env = defineNamespacedVar env ' ' "diverted" $ List [] -- |Examines the input AST to see if it is a macro call. -- If a macro call is found, the code is expanded. @@ -143,38 +143,35 @@ -- |Do the actual work for the 'macroEval' wrapper func _macroEval env lisp@(List (Atom x : _)) apply = do -- Note: If there is a procedure of the same name it will be shadowed by the macro. - isDefined <- liftIO $ isNamespacedRecBound env macroNamespace x - if isDefined - then do - var <- getNamespacedVar env macroNamespace x - -- DEBUG: var <- (trace ("expand: " ++ x) getNamespacedVar) env macroNamespace x - case var of - -- Explicit Renaming - SyntaxExplicitRenaming transformer@(Func _ _ _ _) -> do - renameEnv <- liftIO $ nullEnv -- Local environment used just for this - expanded <- explicitRenamingTransform env renameEnv - lisp transformer apply - _macroEval env expanded apply + var <- getNamespacedVar' env macroNamespace x + -- DEBUG: var <- (trace ("expand: " ++ x) getNamespacedVar) env macroNamespace x + case var of + -- Explicit Renaming + Just (SyntaxExplicitRenaming transformer@(Func _ _ _ _)) -> do + renameEnv <- liftIO $ nullEnv -- Local environment used just for this + expanded <- explicitRenamingTransform env renameEnv + lisp transformer apply + _macroEval env expanded apply - -- Syntax Rules - Syntax (Just defEnv) _ definedInMacro identifiers rules -> do - renameEnv <- liftIO $ nullEnv -- Local environment used just for this - -- invocation to hold renamed variables - cleanupEnv <- liftIO $ nullEnv -- Local environment used just for - -- this invocation to hold new symbols - -- introduced by renaming. We can use - -- this to clean up any left after - -- transformation + -- Syntax Rules + Just (Syntax (Just defEnv) _ definedInMacro identifiers rules) -> do + renameEnv <- liftIO $ nullEnv -- Local environment used just for this + -- invocation to hold renamed variables + cleanupEnv <- liftIO $ nullEnv -- Local environment used just for + -- this invocation to hold new symbols + -- introduced by renaming. We can use + -- this to clean up any left after + -- transformation - -- Transform the input and then call macroEval again, - -- since a macro may be contained within... - expanded <- macroTransform defEnv env env renameEnv cleanupEnv - definedInMacro - (List identifiers) rules lisp apply - _macroEval env expanded apply - -- Useful debug to see all exp's: - -- macroEval env (trace ("exp = " ++ show expanded) expanded) - else return lisp + -- Transform the input and then call macroEval again, + -- since a macro may be contained within... + expanded <- macroTransform defEnv env env renameEnv cleanupEnv + definedInMacro + (List identifiers) rules lisp apply + _macroEval env expanded apply + -- Useful debug to see all exp's: + -- macroEval env (trace ("exp = " ++ show expanded) expanded) + Nothing -> return lisp -- No macro to process, just return code as it is... _macroEval _ lisp@(_) _ = return lisp @@ -415,7 +412,9 @@ flagUnmatchedVar :: Env -> String -> Bool -> IOThrowsError LispVal flagUnmatchedVar localEnv var improperListFlag = do _ <- defineVar localEnv var $ Nil "" -- Empty nil will signify the empty match - defineNamespacedVar localEnv "unmatched nary pattern variable" var $ Bool $ improperListFlag + defineNamespacedVar localEnv + '_' -- "unmatched nary pattern variable" + var $ Bool $ improperListFlag {- - Utility function to insert a True flag to the proper trailing position of the DottedList indicator list @@ -554,8 +553,8 @@ initializePatternVar _ ellipIndex pat val = do let flags = getListFlags ellipIndex listFlags _ <- defineVar localEnv pat (Matches.setData (List []) ellipIndex val) - _ <- defineNamespacedVar localEnv "improper pattern" pat $ Bool $ fst flags - defineNamespacedVar localEnv "improper input" pat $ Bool $ snd flags + _ <- defineNamespacedVar localEnv 'p' {-"improper pattern"-} pat $ Bool $ fst flags + defineNamespacedVar localEnv 'i' {-"improper input"-} pat $ Bool $ snd flags checkLocal defEnv outerEnv divertEnv localEnv renameEnv identifiers ellipsisLevel ellipsisIndex (Vector p) (Vector i) flags = -- For vectors, just use list match for now, since vector input matching just requires a @@ -665,7 +664,7 @@ -- (currently) unused conditional variables for below test --isDiverted <- liftIO $ isRecBound divertEnv a --isMacroBound <- liftIO $ isRecBound renameEnv a - --isLocalRename <- liftIO $ isNamespacedRecBound renameEnv "renamed" a + --isLocalRename <- liftIO $ isNamespacedRecBound renameEnv 'r' {-"renamed"-} a -- Determine if we should recursively rename an atom -- This code is a bit of a hack/mess at the moment @@ -951,14 +950,13 @@ -- |Expand an atom, optionally recursively _expandAtom :: Bool -> Env -> LispVal -> IOThrowsError LispVal _expandAtom isRec renameEnv (Atom a) = do - isDefined <- liftIO $ isRecBound renameEnv a -- Search parent Env's also - if isDefined - then do - expanded <- getVar renameEnv a + isDefined <- getVar' renameEnv a + case isDefined of + Just expanded -> do case isRec of True -> _expandAtom isRec renameEnv expanded False -> return expanded - else return $ Atom a + Nothing -> return $ Atom a _expandAtom _ _ a = return a -- |Recursively expand an atom that may have been renamed multiple times @@ -1169,17 +1167,17 @@ appendNil d _ _ = d -- Should never be reached... loadNamespacedBool namespc = do - isDef <- liftIO $ isNamespacedBound localEnv namespc a - if isDef - then getNamespacedVar localEnv namespc a - else return $ Bool False + val <- getNamespacedVar' localEnv namespc a + case val of + Just b -> return b + Nothing -> return $ Bool False hasEllipsis = macroElementMatchesMany transform ellipsisHere isDefined = do if isDefined then do - isImproperPattern <- loadNamespacedBool "improper pattern" - isImproperInput <- loadNamespacedBool "improper input" + isImproperPattern <- loadNamespacedBool 'p' -- "improper pattern" + isImproperInput <- loadNamespacedBool 'i' -- "improper input" -- Load variable and ensure it is a list var <- getVar localEnv a case var of @@ -1196,8 +1194,8 @@ transformRule defEnv outerEnv divertEnv localEnv renameEnv cleanupEnv dim identifiers ellipsisLevel ellipsisIndex (List result) (List $ tail ts) noEllipsis isDefined = do - isImproperPattern <- loadNamespacedBool "improper pattern" - isImproperInput <- loadNamespacedBool "improper input" + isImproperPattern <- loadNamespacedBool 'p' -- "improper pattern" + isImproperInput <- loadNamespacedBool 'i' -- "improper input" t <- if (isDefined) then do var <- getVar localEnv a @@ -1208,7 +1206,9 @@ -- What's happening here is that the pattern was flagged because it was not matched in -- the pattern. We pick it up and in turn pass a special flag to the outer code (as t) -- so that it can finally be processed correctly. - wasPair <- getNamespacedVar localEnv "unmatched nary pattern variable" a + wasPair <- getNamespacedVar localEnv + '_' -- "unmatched nary pattern variable" + a case wasPair of Bool True -> return $ Nil "var (pair) not defined in pattern" _ -> return $ Nil "var not defined in pattern" @@ -1233,16 +1233,14 @@ -- the same symbol the same new name if it is found more than once, so... -- we need to keep track of the var in two environments to map both ways -- between the original name and the new name. - isAlreadyRenamed <- liftIO $ isNamespacedBound localEnv "renamed" a - if isAlreadyRenamed - then do - renamed <- getNamespacedVar localEnv "renamed" a --- return (trace ("macro call renaming (again) " ++ a ++ " to " ++ show renamed) renamed) - return renamed - else do + + alreadyRenamed <- getNamespacedVar' localEnv 'r' {-"renamed"-} a + case alreadyRenamed of + Just renamed -> return renamed + Nothing -> do Atom renamed <- _gensym a - _ <- defineNamespacedVar localEnv "renamed" a $ Atom renamed - _ <- defineNamespacedVar renameEnv "renamed" a $ Atom renamed + _ <- defineNamespacedVar localEnv 'r' {-"renamed"-} a $ Atom renamed + _ <- defineNamespacedVar renameEnv 'r' {-"renamed"-} a $ Atom renamed -- Keep track of vars that are renamed; maintain reverse mapping _ <- defineVar cleanupEnv renamed $ Atom a -- Global record for final cleanup of macro _ <- defineVar (renameEnv) renamed $ Atom a -- Keep for Clinger @@ -1323,9 +1321,9 @@ _ <- defineVar divertEnv renamed value -- TODO: this is temporary testing code - List diverted <- getNamespacedVar outerEnv " " "diverted" - _ <- setNamespacedVar outerEnv " " "diverted" $ - List (diverted ++ [List [Atom renamed, Atom transform]]) +-- List diverted <- getNamespacedVar outerEnv " " "diverted" +-- _ <- setNamespacedVar outerEnv " " "diverted" $ +-- List (diverted ++ [List [Atom renamed, Atom transform]]) -- END return $ Atom renamed diff --git a/hs-src/Language/Scheme/Macro/ExplicitRenaming.hs b/hs-src/Language/Scheme/Macro/ExplicitRenaming.hs --- a/hs-src/Language/Scheme/Macro/ExplicitRenaming.hs +++ b/hs-src/Language/Scheme/Macro/ExplicitRenaming.hs @@ -74,21 +74,19 @@ if isDef then do - -- NOTE: useEnv/"er" is used to store renamed variables due + -- NOTE: useEnv/'r' is used to store renamed variables due -- to issues with separate invocations of er macros -- renaming the same variable differently within the -- same context. This caused the module meta language -- to not work properly... - isRenamed <- liftIO $ isNamespacedRecBound useEnv "er" a - if isRenamed - then do - renamed <- getNamespacedVar useEnv "er" a - return renamed - else do + r <- getNamespacedVar' useEnv 'r' a + case r of + Just renamed -> return renamed + Nothing -> do value <- getVar defEnv a Atom renamed <- _gensym a -- Unique name _ <- defineVar useEnv renamed value -- divert value to Use Env - _ <- defineNamespacedVar useEnv "er" a $ Atom renamed -- Record renamed sym + _ <- defineNamespacedVar useEnv 'r' a $ Atom renamed -- Record renamed sym -- TODO: this is temporary testing code -- List diverted <- getNamespacedVar useEnv " " "diverted" diff --git a/hs-src/Language/Scheme/Primitives.hs b/hs-src/Language/Scheme/Primitives.hs --- a/hs-src/Language/Scheme/Primitives.hs +++ b/hs-src/Language/Scheme/Primitives.hs @@ -47,6 +47,8 @@ , hashTblValues , hashTblCopy , hashTblMake + , wrapHashTbl + , wrapLeadObj -- ** String , buildString , makeString @@ -91,6 +93,7 @@ , unpackEquals , boolBinop , unaryOp + , unaryOp' , strBoolBinop , charBoolBinop , boolBoolBinop @@ -123,6 +126,7 @@ import Language.Scheme.Numerical import Language.Scheme.Parser import Language.Scheme.Types +import Language.Scheme.Variables --import qualified Control.Exception import Control.Monad.Error import qualified Data.ByteString as BS @@ -150,6 +154,7 @@ makePort :: IOMode -> [LispVal] -> IOThrowsError LispVal makePort mode [String filename] = liftM Port $ liftIO $ openFile filename mode +makePort mode [p@(Pointer _ _)] = recDerefPtrs p >>= box >>= makePort mode makePort _ [] = throwError $ NumArgs (Just 1) [] makePort _ args@(_ : _) = throwError $ NumArgs (Just 1) args @@ -211,9 +216,12 @@ {- writeProc :: --forall a (m :: * -> *). (MonadIO m, MonadError LispError m) => (Handle -> LispVal -> IO a) -> [LispVal] -> m LispVal -} -writeProc func [obj] = writeProc func [obj, Port stdout] +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 - output <- liftIO $ try' (liftIO $ func port obj) + dobj <- recDerefPtrs obj -- Last opportunity to do this before writing + output <- liftIO $ try' (liftIO $ func port dobj) case output of Left _ -> throwError $ Default "I/O error writing to port" Right _ -> return $ Nil "" @@ -233,12 +241,14 @@ else throwError $ NumArgs (Just 2) other fileExists, deleteFile :: [LispVal] -> IOThrowsError LispVal +fileExists [p@(Pointer _ _)] = recDerefPtrs p >>= box >>= fileExists fileExists [String filename] = do exists <- liftIO $ doesFileExist filename return $ Bool exists fileExists [] = throwError $ NumArgs (Just 1) [] fileExists args@(_ : _) = throwError $ NumArgs (Just 1) args +deleteFile [p@(Pointer _ _)] = recDerefPtrs p >>= box >>= deleteFile deleteFile [String filename] = do output <- liftIO $ try' (liftIO $ removeFile filename) case output of @@ -249,6 +259,7 @@ readContents :: [LispVal] -> IOThrowsError LispVal readContents [String filename] = liftM String $ liftIO $ readFile filename +readContents [p@(Pointer _ _)] = recDerefPtrs p >>= box >>= readContents readContents [] = throwError $ NumArgs (Just 1) [] readContents args@(_ : _) = throwError $ NumArgs (Just 1) args @@ -260,6 +271,7 @@ else throwError $ Default $ "File does not exist: " ++ filename readAll :: [LispVal] -> IOThrowsError LispVal +readAll [p@(Pointer _ _)] = recDerefPtrs p >>= box >>= readAll readAll [String filename] = liftM List $ load filename readAll [] = throwError $ NumArgs (Just 1) [] readAll args@(_ : _) = throwError $ NumArgs (Just 1) args @@ -273,6 +285,7 @@ -- |Generate a (reasonably) unique symbol, given an optional prefix. -- This function is provided even though it is not part of R5RS. gensym :: [LispVal] -> IOThrowsError LispVal +gensym [p@(Pointer _ _)] = recDerefPtrs p >>= box >>= gensym gensym [String prefix] = _gensym prefix gensym [] = _gensym " g" gensym args@(_ : _) = throwError $ NumArgs (Just 1) args @@ -283,20 +296,25 @@ --------------------------------------------------- -- List primitives -car :: [LispVal] -> ThrowsError LispVal +car :: [LispVal] -> IOThrowsError LispVal +car [p@(Pointer _ _)] = derefPtr p >>= box >>= car car [List (x : _)] = return x car [DottedList (x : _) _] = return x car [badArg] = throwError $ TypeMismatch "pair" badArg car badArgList = throwError $ NumArgs (Just 1) badArgList -cdr :: [LispVal] -> ThrowsError LispVal +cdr :: [LispVal] -> IOThrowsError LispVal +cdr [p@(Pointer _ _)] = derefPtr p >>= box >>= cdr cdr [List (_ : xs)] = return $ List xs cdr [DottedList [_] x] = return x cdr [DottedList (_ : xs) x] = return $ DottedList xs x cdr [badArg] = throwError $ TypeMismatch "pair" badArg cdr badArgList = throwError $ NumArgs (Just 1) badArgList -cons :: [LispVal] -> ThrowsError LispVal +cons :: [LispVal] -> IOThrowsError LispVal +cons [x, p@(Pointer _ _)] = do + y <- derefPtr p + cons [x, y] cons [x1, List []] = return $ List [x1] cons [x, List xs] = return $ List $ x : xs cons [x, DottedList xs xlast] = return $ DottedList (x : xs) xlast @@ -324,8 +342,7 @@ makeVector [badType] = throwError $ TypeMismatch "integer" badType makeVector badArgList = throwError $ NumArgs (Just 1) badArgList -buildVector (o : os) = do - let lst = o : os +buildVector lst@(o : os) = do return $ Vector $ (listArray (0, length lst - 1)) lst buildVector badArgList = throwError $ NumArgs (Just 1) badArgList @@ -350,7 +367,7 @@ listToVector badArgList = throwError $ NumArgs (Just 1) badArgList -- ------------ Bytevector Primitives -------------- -makeByteVector, byteVector, byteVectorLength, byteVectorRef, byteVectorCopy, byteVectorAppend, byteVectorUtf2Str, byteVectorStr2Utf :: [LispVal] -> ThrowsError LispVal +makeByteVector, byteVector :: [LispVal] -> ThrowsError LispVal makeByteVector [(Number n)] = do let ls = replicate (fromInteger n) (0 :: Word8) return $ ByteVector $ BS.pack ls @@ -366,6 +383,10 @@ conv (Number n) = fromInteger n :: Word8 conv n = 0 :: Word8 +byteVectorLength, byteVectorRef, byteVectorCopy, byteVectorAppend, byteVectorUtf2Str :: [LispVal] -> IOThrowsError LispVal +byteVectorCopy (p@(Pointer _ _) : lvs) = do + bv <- derefPtr p + byteVectorCopy (bv : lvs) byteVectorCopy [ByteVector bv] = do return $ ByteVector $ BS.copy bv @@ -384,16 +405,24 @@ byteVectorAppend bs = do let acc = BS.pack [] - conv (ByteVector bs) = bs - conv x = BS.empty - bs' = map conv bs + conv :: LispVal -> IOThrowsError BSU.ByteString + conv p@(Pointer _ _) = do + bs <- derefPtr p + conv bs + conv (ByteVector bs) = return bs + conv x = return BS.empty + bs' <- mapM conv bs return $ ByteVector $ BS.concat bs' -- TODO: error handling +byteVectorLength [p@(Pointer _ _)] = derefPtr p >>= box >>= byteVectorLength byteVectorLength [(ByteVector bv)] = return $ Number $ toInteger $ BS.length bv byteVectorLength [badType] = throwError $ TypeMismatch "bytevector" badType byteVectorLength badArgList = throwError $ NumArgs (Just 1) badArgList +byteVectorRef (p@(Pointer _ _) : lvs) = do + bv <- derefPtr p + byteVectorRef (bv : lvs) byteVectorRef [(ByteVector bv), (Number n)] = do let len = toInteger $ (BS.length bv) - 1 if n > len || n < 0 @@ -402,11 +431,15 @@ byteVectorRef [badType] = throwError $ TypeMismatch "bytevector integer" badType byteVectorRef badArgList = throwError $ NumArgs (Just 2) badArgList +byteVectorUtf2Str [p@(Pointer _ _)] = derefPtr p >>= box >>= byteVectorUtf2Str byteVectorUtf2Str [(ByteVector bv)] = do return $ String $ BSU.toString bv -- TODO: need to support other overloads of this function byteVectorUtf2Str [badType] = throwError $ TypeMismatch "bytevector" badType byteVectorUtf2Str badArgList = throwError $ NumArgs (Just 1) badArgList + +byteVectorStr2Utf :: [LispVal] -> IOThrowsError LispVal +byteVectorStr2Utf [p@(Pointer _ _)] = derefPtr p >>= box >>= byteVectorStr2Utf byteVectorStr2Utf [(String s)] = do return $ ByteVector $ BSU.fromString s -- TODO: need to support other overloads of this function @@ -414,6 +447,26 @@ byteVectorStr2Utf badArgList = throwError $ NumArgs (Just 1) badArgList +-- ------------ Ptr Helper Primitives -------------- + +wrapHashTbl, wrapLeadObj :: ([LispVal] -> ThrowsError LispVal) -> [LispVal] -> IOThrowsError LispVal +wrapHashTbl fnc [p@(Pointer _ _)] = do + val <- derefPtr p + liftThrows $ fnc [val] +wrapHashTbl fnc (p@(Pointer _ _) : key : args) = do + ht <- derefPtr p + k <- recDerefPtrs key + liftThrows $ fnc (ht : k : args) +wrapHashTbl fnc args = liftThrows $ fnc args + +wrapLeadObj fnc [p@(Pointer _ _)] = do + val <- derefPtr p + liftThrows $ fnc [val] +wrapLeadObj fnc (p@(Pointer _ _) : args) = do + obj <- derefPtr p + liftThrows $ fnc (obj : args) +wrapLeadObj fnc args = liftThrows $ fnc args + -- ------------ Hash Table Primitives -------------- -- Future: support (equal?), (hash) parameters @@ -490,17 +543,22 @@ then String s else doMakeString (n - 1) char (s ++ [char]) -stringLength :: [LispVal] -> ThrowsError LispVal +stringLength :: [LispVal] -> IOThrowsError LispVal +stringLength [p@(Pointer _ _)] = derefPtr p >>= box >>= stringLength stringLength [String s] = return $ Number $ foldr (const (+ 1)) 0 s -- Could probably do 'length s' instead... stringLength [badType] = throwError $ TypeMismatch "string" badType stringLength badArgList = throwError $ NumArgs (Just 1) badArgList -stringRef :: [LispVal] -> ThrowsError LispVal +stringRef :: [LispVal] -> IOThrowsError LispVal +stringRef [p@(Pointer _ _)] = derefPtr p >>= box >>= stringRef stringRef [(String s), (Number k)] = return $ Char $ s !! fromInteger k stringRef [badType] = throwError $ TypeMismatch "string number" badType stringRef badArgList = throwError $ NumArgs (Just 2) badArgList -substring :: [LispVal] -> ThrowsError LispVal +substring :: [LispVal] -> IOThrowsError LispVal +substring (p@(Pointer _ _) : lvs) = do + s <- derefPtr p + substring (s : lvs) substring [(String s), (Number start), (Number end)] = do let slength = fromInteger $ end - start let begin = fromInteger start @@ -508,31 +566,42 @@ substring [badType] = throwError $ TypeMismatch "string number number" badType substring badArgList = throwError $ NumArgs (Just 3) badArgList -stringCIEquals :: [LispVal] -> ThrowsError LispVal -stringCIEquals [(String str1), (String str2)] = do - if (length str1) /= (length str2) - then return $ Bool False - else return $ Bool $ ciCmp str1 str2 0 - where ciCmp s1 s2 idx = if idx == (length s1) - then True - else if (toLower $ s1 !! idx) == (toLower $ s2 !! idx) - then ciCmp s1 s2 (idx + 1) - else False -stringCIEquals [badType] = throwError $ TypeMismatch "string string" badType -stringCIEquals badArgList = throwError $ NumArgs (Just 2) badArgList +stringCIEquals :: [LispVal] -> IOThrowsError LispVal +stringCIEquals args = do + List dargs <- recDerefPtrs $ List args + case dargs of + [(String str1), (String str2)] -> do + if (length str1) /= (length str2) + then return $ Bool False + else return $ Bool $ ciCmp str1 str2 0 + [badType] -> throwError $ TypeMismatch "string string" badType + badArgList -> throwError $ NumArgs (Just 2) badArgList + where ciCmp s1 s2 idx = + if idx == (length s1) + then True + else if (toLower $ s1 !! idx) == (toLower $ s2 !! idx) + then ciCmp s1 s2 (idx + 1) + else False -stringCIBoolBinop :: ([Char] -> [Char] -> Bool) -> [LispVal] -> ThrowsError LispVal -stringCIBoolBinop op [(String s1), (String s2)] = boolBinop unpackStr op [(String $ strToLower s1), (String $ strToLower s2)] +stringCIBoolBinop :: ([Char] -> [Char] -> Bool) -> [LispVal] -> IOThrowsError LispVal +stringCIBoolBinop op args = do + List dargs <- recDerefPtrs $ List args -- Deref any pointers + case dargs of + [(String s1), (String s2)] -> + liftThrows $ boolBinop unpackStr op [(String $ strToLower s1), (String $ strToLower s2)] + [badType] -> throwError $ TypeMismatch "string string" badType + badArgList -> throwError $ NumArgs (Just 2) badArgList where strToLower str = map (toLower) str -stringCIBoolBinop _ [badType] = throwError $ TypeMismatch "string string" badType -stringCIBoolBinop _ badArgList = throwError $ NumArgs (Just 2) badArgList charCIBoolBinop :: (Char -> Char -> Bool) -> [LispVal] -> ThrowsError LispVal charCIBoolBinop op [(Char s1), (Char s2)] = boolBinop unpackChar op [(Char $ toLower s1), (Char $ toLower s2)] charCIBoolBinop _ [badType] = throwError $ TypeMismatch "character character" badType charCIBoolBinop _ badArgList = throwError $ NumArgs (Just 2) badArgList -stringAppend :: [LispVal] -> ThrowsError LispVal +stringAppend :: [LispVal] -> IOThrowsError LispVal +stringAppend (p@(Pointer _ _) : lvs) = do + s <- derefPtr p + stringAppend (s : lvs) stringAppend [(String s)] = return $ String s -- Needed for "last" string value stringAppend (String st : sts) = do rest <- stringAppend sts @@ -542,9 +611,12 @@ stringAppend [badType] = throwError $ TypeMismatch "string" badType stringAppend badArgList = throwError $ NumArgs (Just 1) badArgList -stringToNumber :: [LispVal] -> ThrowsError LispVal +stringToNumber :: [LispVal] -> IOThrowsError LispVal +stringToNumber (p@(Pointer _ _) : lvs) = do + s <- derefPtr p + stringToNumber (s : lvs) stringToNumber [(String s)] = do - result <- (readExpr s) + result <- liftThrows $ readExpr s case result of n@(Number _) -> return n n@(Rational _) -> return n @@ -561,24 +633,28 @@ stringToNumber [badType] = throwError $ TypeMismatch "string" badType stringToNumber badArgList = throwError $ NumArgs (Just 1) badArgList -stringToList :: [LispVal] -> ThrowsError LispVal +stringToList :: [LispVal] -> IOThrowsError LispVal +stringToList [p@(Pointer _ _)] = derefPtr p >>= box >>= stringToList stringToList [(String s)] = return $ List $ map (Char) s stringToList [badType] = throwError $ TypeMismatch "string" badType stringToList badArgList = throwError $ NumArgs (Just 1) badArgList -listToString :: [LispVal] -> ThrowsError LispVal +listToString :: [LispVal] -> IOThrowsError LispVal +listToString [p@(Pointer _ _)] = derefPtr p >>= box >>= listToString listToString [(List [])] = return $ String "" -listToString [(List l)] = buildString l +listToString [(List l)] = liftThrows $ buildString l listToString [badType] = throwError $ TypeMismatch "list" badType listToString [] = throwError $ NumArgs (Just 1) [] listToString args@(_ : _) = throwError $ NumArgs (Just 1) args -stringCopy :: [LispVal] -> ThrowsError LispVal +stringCopy :: [LispVal] -> IOThrowsError LispVal +stringCopy [p@(Pointer _ _)] = derefPtr p >>= box >>= stringCopy stringCopy [String s] = return $ String s stringCopy [badType] = throwError $ TypeMismatch "string" badType stringCopy badArgList = throwError $ NumArgs (Just 2) badArgList -isDottedList :: [LispVal] -> ThrowsError LispVal +isDottedList :: [LispVal] -> IOThrowsError LispVal +isDottedList ([p@(Pointer _ _)]) = derefPtr p >>= box >>= isDottedList isDottedList ([DottedList _ _]) = return $ Bool True -- Must include lists as well since they are made up of 'chains' of pairs isDottedList ([List []]) = return $ Bool False @@ -593,17 +669,19 @@ isProcedure ([EvalFunc _]) = return $ Bool True isProcedure _ = return $ Bool False -isVector, isList :: LispVal -> ThrowsError LispVal +isVector,isByteVector, isList :: LispVal -> IOThrowsError LispVal +isVector p@(Pointer _ _) = derefPtr p >>= isVector isVector (Vector _) = return $ Bool True isVector _ = return $ Bool False -isList (List _) = return $ Bool True -isList _ = return $ Bool False - -isByteVector :: LispVal -> ThrowsError LispVal +isByteVector p@(Pointer _ _) = derefPtr p >>= isVector isByteVector (ByteVector _) = return $ Bool True isByteVector _ = return $ Bool False +isList p@(Pointer _ _) = derefPtr p >>= isList +isList (List _) = return $ Bool True +isList _ = return $ Bool False -isNull :: [LispVal] -> ThrowsError LispVal +isNull :: [LispVal] -> IOThrowsError LispVal +isNull ([p@(Pointer _ _)]) = derefPtr p >>= box >>= isNull isNull ([List []]) = return $ Bool True isNull _ = return $ Bool False @@ -621,7 +699,8 @@ symbol2String [] = throwError $ NumArgs (Just 1) [] symbol2String args@(_ : _) = throwError $ NumArgs (Just 1) args -string2Symbol :: [LispVal] -> ThrowsError LispVal +string2Symbol :: [LispVal] -> IOThrowsError LispVal +string2Symbol ([p@(Pointer _ _)]) = derefPtr p >>= box >>= string2Symbol string2Symbol ([String s]) = return $ Atom s string2Symbol [] = throwError $ NumArgs (Just 1) [] string2Symbol [notString] = throwError $ TypeMismatch "string" notString @@ -652,7 +731,8 @@ isChar ([Char _]) = return $ Bool True isChar _ = return $ Bool False -isString :: [LispVal] -> ThrowsError LispVal +isString :: [LispVal] -> IOThrowsError LispVal +isString [p@(Pointer _ _)] = derefPtr p >>= box >>= isString isString ([String _]) = return $ Bool True isString _ = return $ Bool False @@ -683,10 +763,16 @@ unaryOp _ [] = throwError $ NumArgs (Just 1) [] unaryOp _ args@(_ : _) = throwError $ NumArgs (Just 1) args -{- numBoolBinop :: (Integer -> Integer -> Bool) -> [LispVal] -> ThrowsError LispVal -numBoolBinop = boolBinop unpackNum -} -strBoolBinop :: (String -> String -> Bool) -> [LispVal] -> ThrowsError LispVal -strBoolBinop = boolBinop unpackStr +unaryOp' :: (LispVal -> IOThrowsError LispVal) -> [LispVal] -> IOThrowsError LispVal +unaryOp' f [v] = f v +unaryOp' _ [] = throwError $ NumArgs (Just 1) [] +unaryOp' _ args@(_ : _) = throwError $ NumArgs (Just 1) args + +strBoolBinop :: (String -> String -> Bool) -> [LispVal] -> IOThrowsError LispVal +strBoolBinop fnc args = do + List dargs <- recDerefPtrs $ List args -- Deref any pointers + liftThrows $ boolBinop unpackStr fnc dargs + charBoolBinop = boolBinop unpackChar boolBoolBinop :: (Bool -> Bool -> Bool) -> [LispVal] -> ThrowsError LispVal boolBoolBinop = boolBinop unpackBool diff --git a/hs-src/Language/Scheme/Types.hs b/hs-src/Language/Scheme/Types.hs --- a/hs-src/Language/Scheme/Types.hs +++ b/hs-src/Language/Scheme/Types.hs @@ -22,11 +22,7 @@ , LispError (..) , ThrowsError , IOThrowsError - , trapError - , extractValue , liftThrows - , runIOThrowsREPL - , runIOThrows -- * Types and related functions , LispVal ( Atom @@ -54,6 +50,7 @@ , hbody , hclosure , IOFunc + , CustFunc , EvalFunc , Pointer , pointerVar @@ -86,6 +83,7 @@ , eqv , eqvList , eqVal + , box , makeFunc , makeNormalFunc , makeVarargs @@ -161,17 +159,6 @@ -- |Container used by operations that could throw an error type ThrowsError = Either LispError --- |Error handler that returns a string description of any error -trapError :: -- forall (m :: * -> *) e. - (MonadError e m, Show e) => - m String -> m String -trapError action = catchError action (return . show) - --- |Utility function to unwrap a value from ThrowsError -extractValue :: ThrowsError a -> a -extractValue (Right val) = val -extractValue (Left _) = error "Unexpected error in extractValue" - -- |Container used to provide error handling in the IO monad type IOThrowsError = ErrorT LispError IO @@ -180,20 +167,6 @@ liftThrows (Left err) = throwError err liftThrows (Right val) = return val --- |Execute an IO action and return result or an error message. --- This is intended for use by a REPL, where a result is always --- needed regardless of type. -runIOThrowsREPL :: IOThrowsError String -> IO String -runIOThrowsREPL action = runErrorT (trapError action) >>= return . extractValue - --- |Execute an IO action and return error or Nothing if no error was thrown. -runIOThrows :: IOThrowsError String -> IO (Maybe String) -runIOThrows action = do - runState <- runErrorT action - case runState of - Left err -> return $ Just (show err) - Right _ -> return $ Nothing - -- |Scheme data types data LispVal = Atom String -- ^Symbol @@ -236,7 +209,7 @@ body :: [LispVal], closure :: Env } - -- ^Function + -- ^Function written in Scheme | HFunc {hparams :: [String], hvararg :: (Maybe String), hbody :: (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal), @@ -248,6 +221,10 @@ | EvalFunc ([LispVal] -> IOThrowsError LispVal) {- ^Function within the IO monad with access to the current environment and continuation. -} + | CustFunc ([LispVal] -> IOThrowsError LispVal) + -- ^A custom function written by code outside of husk. + -- Any code that uses the Haskell API should define custom + -- functions using this data type. | Pointer { pointerVar :: String ,pointerEnv :: Env } -- ^Pointer to an environment variable. @@ -412,6 +389,7 @@ -- eqv [x@(PrimitiveFunc _), y@(PrimitiveFunc _)] = return $ Bool $ (show x) == (show y) eqv [x@(IOFunc _), y@(IOFunc _)] = return $ Bool $ (show x) == (show y) +eqv [x@(CustFunc _), y@(CustFunc _)] = return $ Bool $ (show x) == (show y) eqv [x@(EvalFunc _), y@(EvalFunc _)] = return $ Bool $ (show x) == (show y) -- FUTURE: comparison of two continuations eqv [l1@(List _), l2@(List _)] = eqvList eqv [l1, l2] @@ -475,9 +453,14 @@ Just arg -> " . " ++ arg) ++ ") ...)" showVal (Port _) = "" showVal (IOFunc _) = "" +showVal (CustFunc _) = "" showVal (EvalFunc _) = "" showVal (Pointer p _) = "" showVal (Opaque d) = "" + +-- |A helper function to make pointer deref code more concise +box :: LispVal -> IOThrowsError [LispVal] +box a = return [a] -- |Convert a list of Lisp objects into a space-separated string unwordsList :: [LispVal] -> String diff --git a/hs-src/Language/Scheme/Variables.hs b/hs-src/Language/Scheme/Variables.hs --- a/hs-src/Language/Scheme/Variables.hs +++ b/hs-src/Language/Scheme/Variables.hs @@ -29,7 +29,9 @@ , varNamespace -- * Getters , getVar + , getVar' , getNamespacedVar + , getNamespacedVar' -- * Setters , defineVar , defineNamespacedVar @@ -40,10 +42,10 @@ -- * Predicates , isBound , isRecBound - , isNamespacedBound , isNamespacedRecBound -- * Pointers , derefPtr +-- , derefPtrs , recDerefPtrs ) where import Language.Scheme.Types @@ -54,12 +56,12 @@ -- import Debug.Trace -- |Internal namespace for macros -macroNamespace :: [Char] -macroNamespace = "m" +macroNamespace :: Char +macroNamespace = 'm' -- |Internal namespace for variables -varNamespace :: [Char] -varNamespace = "v" +varNamespace :: Char +varNamespace = 'v' -- Experimental code: -- From: http://rafaelbarreto.com/2011/08/21/comparing-objects-by-memory-location-in-haskell/ @@ -91,8 +93,8 @@ -- -- |Create a variable's name in an environment using given arguments -getVarName :: String -> String -> String -getVarName namespace name = namespace ++ "_" ++ name +getVarName :: Char -> String -> String +getVarName namespace name = (namespace : ('_' : name)) -- |Show the contents of an environment printEnv :: Env -- ^Environment @@ -158,7 +160,7 @@ -- |Extend given environment by binding a series of values to a new environment. extendEnv :: Env -- ^ Environment - -> [((String, String), LispVal)] -- ^ Extensions to the environment + -> [((Char, String), LispVal)] -- ^ Extensions to the environment -> IO Env -- ^ Extended environment extendEnv envRef abindings = do bindinglistT <- (mapM addBinding abindings) -- >>= newIORef @@ -184,7 +186,7 @@ findNamespacedEnv :: Env -- ^Environment to begin the search; -- parent env's will be searched as well. - -> String -- ^Namespace + -> Char -- ^Namespace -> String -- ^Variable -> IO (Maybe Env) -- ^Environment, or Nothing if there was no match. findNamespacedEnv envRef namespace var = do @@ -211,7 +213,7 @@ -- |Determine if a variable is bound in a given namespace isNamespacedBound :: Env -- ^ Environment - -> String -- ^ Namespace + -> Char -- ^ Namespace -> String -- ^ Variable -> IO Bool -- ^ True if the variable is bound isNamespacedBound envRef namespace var = @@ -221,7 +223,7 @@ -- or a parent of the given environment. isNamespacedRecBound :: Env -- ^ Environment - -> String -- ^ Namespace + -> Char -- ^ Namespace -> String -- ^ Variable -> IO Bool -- ^ True if the variable is bound isNamespacedRecBound envRef namespace var = do @@ -236,20 +238,43 @@ -> IOThrowsError LispVal -- ^ Contents of the variable getVar envRef var = getNamespacedVar envRef varNamespace var +-- |Retrieve the value of a variable defined in the default namespace, +-- or Nothing if it is not defined +getVar' :: Env -- ^ Environment + -> String -- ^ Variable + -> IOThrowsError (Maybe LispVal) -- ^ Contents of the variable +getVar' envRef var = getNamespacedVar' envRef varNamespace var + -- |Retrieve the value of a variable defined in a given namespace getNamespacedVar :: Env -- ^ Environment - -> String -- ^ Namespace + -> Char -- ^ Namespace -> String -- ^ Variable -> IOThrowsError LispVal -- ^ Contents of the variable getNamespacedVar envRef namespace - var = do binds <- liftIO $ readIORef $ bindings envRef - case Data.Map.lookup (getVarName namespace var) binds of - (Just a) -> liftIO $ readIORef a - Nothing -> case parentEnv envRef of - (Just par) -> getNamespacedVar par namespace var - Nothing -> (throwError $ UnboundVar "Getting an unbound variable" var) + var = do + v <- getNamespacedVar' envRef namespace var + case v of + Just a -> return a + Nothing -> (throwError $ UnboundVar "Getting an unbound variable" var) +-- |Retrieve the value of a variable defined in a given namespace, +-- or Nothing if it is not defined +getNamespacedVar' :: Env -- ^ Environment + -> Char -- ^ Namespace + -> String -- ^ Variable + -> IOThrowsError (Maybe LispVal) -- ^ Contents of the variable, if found +getNamespacedVar' envRef + namespace + var = do + binds <- liftIO $ readIORef $ bindings envRef + case Data.Map.lookup (getVarName namespace var) binds of + (Just a) -> do + v <- liftIO $ readIORef a + return $ Just v + Nothing -> case parentEnv envRef of + (Just par) -> getNamespacedVar' par namespace var + Nothing -> return Nothing -- |Set a variable in the default namespace setVar @@ -262,7 +287,7 @@ -- |Set a variable in a given namespace setNamespacedVar :: Env -- ^ Environment - -> String -- ^ Namespace + -> Char -- ^ Namespace -> String -- ^ Variable -> LispVal -- ^ Value -> IOThrowsError LispVal -- ^ Value @@ -296,7 +321,7 @@ -- for purposes of book-keeping. _setNamespacedVar :: Env -- ^ Environment - -> String -- ^ Namespace + -> Char -- ^ Namespace -> String -- ^ Variable -> LispVal -- ^ Value -> IOThrowsError LispVal -- ^ Value @@ -323,7 +348,7 @@ -- |This helper function is used to keep pointers in sync when -- a variable is bound to a different value. -updatePointers :: Env -> String -> String -> IOThrowsError LispVal +updatePointers :: Env -> Char -> String -> IOThrowsError LispVal updatePointers envRef namespace var = do ptrs <- liftIO $ readIORef $ pointers envRef case Data.Map.lookup (getVarName namespace var) ptrs of @@ -360,7 +385,7 @@ where -- |Move the given pointers (ptr) to the list of -- pointers for variable (var) - movePointers :: Env -> String -> String -> [LispVal] -> IOThrowsError LispVal + movePointers :: Env -> Char -> String -> [LispVal] -> IOThrowsError LispVal movePointers envRef namespace var ptrs = do env <- liftIO $ readIORef $ pointers envRef case Data.Map.lookup (getVarName namespace var) env of @@ -397,7 +422,7 @@ -- update any associated pointers. So it should probably only be -- used internally by husk, unless you really know what you are -- doing! -updateNamespacedObject :: Env -> String -> String -> LispVal -> IOThrowsError LispVal +updateNamespacedObject :: Env -> Char -> String -> LispVal -> IOThrowsError LispVal updateNamespacedObject env namespace var value = do varContents <- getNamespacedVar env namespace var obj <- findPointerTo varContents @@ -417,7 +442,7 @@ -- |Bind a variable in the given namespace defineNamespacedVar :: Env -- ^ Environment - -> String -- ^ Namespace + -> Char -- ^ Namespace -> String -- ^ Variable -> LispVal -- ^ Value -> IOThrowsError LispVal -- ^ Value @@ -452,7 +477,7 @@ -- based on the value passed to the define/set function. Normally this -- is straightforward, but there is book-keeping involved if a -- pointer is passed, depending on if the pointer resolves to an object. -getValueToStore :: String -> String -> Env -> LispVal -> IOThrowsError LispVal +getValueToStore :: Char -> String -> Env -> LispVal -> IOThrowsError LispVal getValueToStore namespace var env (Pointer p pEnv) = do addReversePointer namespace p pEnv namespace var env getValueToStore _ _ _ value = return value @@ -461,7 +486,7 @@ -- to be assigned to. If that variable is an object then we setup a reverse lookup -- for future book-keeping. Otherwise, we just look it up and return it directly, -- no booking-keeping required. -addReversePointer :: String -> String -> Env -> String -> String -> Env -> IOThrowsError LispVal +addReversePointer :: Char -> String -> Env -> Char -> String -> Env -> IOThrowsError LispVal addReversePointer namespace var envRef ptrNamespace ptrVar ptrEnvRef = do env <- liftIO $ readIORef $ bindings envRef case Data.Map.lookup (getVarName namespace var) env of @@ -507,6 +532,11 @@ derefPtr result derefPtr v = return v +-- -- |Return the given list of values, but if any of the +-- -- original values is a pointer it will be dereferenced +-- derefPtrs :: [LispVal] -> IOThrowsError LispVal +-- derefPtrs lvs = mapM (liftThrows $ derefPtr) lvs + -- |Recursively process the given data structure, dereferencing -- any pointers found along the way. -- @@ -543,6 +573,7 @@ isObject (String _) = True isObject (Vector _) = True isObject (HashTable _) = True +isObject (ByteVector _) = True isObject (Pointer _ _) = True isObject _ = False diff --git a/husk-scheme.cabal b/husk-scheme.cabal --- a/husk-scheme.cabal +++ b/husk-scheme.cabal @@ -1,5 +1,5 @@ Name: husk-scheme -Version: 3.7 +Version: 3.8 Synopsis: R5RS Scheme interpreter, compiler, and library. Description: <> @@ -42,7 +42,7 @@ ChangeLog.markdown LICENSE AUTHORS -Data-Files: lib/*.scm lib/r5rs/*.sld lib/scheme/*.sld lib/srfi/*.scm +Data-Files: lib/*.scm lib/scheme/*.sld lib/scheme/r5rs/*.sld lib/srfi/*.scm Source-Repository head Type: git diff --git a/lib/r5rs/base.sld b/lib/r5rs/base.sld deleted file mode 100644 --- a/lib/r5rs/base.sld +++ /dev/null @@ -1,3 +0,0 @@ -(define-library (r5rs base) - (export-all) - (import (r5rs))) diff --git a/lib/scheme/r5rs/base.sld b/lib/scheme/r5rs/base.sld new file mode 100644 --- /dev/null +++ b/lib/scheme/r5rs/base.sld @@ -0,0 +1,256 @@ +;;; +;;; husk-scheme +;;; http://justinethier.github.com/husk-scheme +;;; +;;; Written by Justin Ethier +;;; +;;; r5rs equivalent libraries +;;; +;;; This library exposes an R5RS equivalent to +;;; the corresponding R7RS-small library. +;;; + +(define-library (scheme r5rs base) + (export + * + + + - + / + < + <= + = + > + >= + abs + and + append + apply + assoc + assq + assv + begin + boolean? + bytevector + bytevector-append + bytevector-copy + bytevector-copy! + bytevector-length + bytevector-u8-ref + bytevector? + caar + cadr + call-with-current-continuation + call-with-values + call/cc + car + case + cdar + cddr + cdr + ceiling + char->integer + char-ready? + char<=? + char=? + char>? + char? + close-input-port + close-output-port + complex? + cond + cons + current-input-port + current-output-port + denominator + do + dynamic-wind + eof-object? + eq? + equal? + eqv? + error + even? + exact->inexact ; r5rs definition + expt + floor + for-each + gcd + import + include + include-ci + inexact->exact ; r5rs definition + input-port? + integer->char + integer? + lcm + length + let + let* + letrec + list + list->string + list->vector + list-ref + list-tail + list? + make-bytevector + make-string + make-vector + map + max + member + memq + memv + min + modulo + negative? + newline + not + null? + number->string + number? + numerator + odd? + or + output-port? + pair? + peek-char + positive? + procedure? + quasiquote + quotient + rational? + rationalize + read-char + real? + remainder + reverse + round + string + string->list + string->number + string->symbol + string->utf8 + string-append + string-copy + string-length + string-ref + string<=? + string=? + string>? + string? + substring + symbol->string + symbol? + truncate + utf8->string + values + vector + vector->list + vector-length + vector-ref + vector? + write-char + zero? + + ;=> + ;binary-port? + ;boolean=? + ;bytevector-u8-set! + ;call-with-port + ;close-port + ;cond-expand + ;current-error-port + ;define + ;define-record-type + ;define-syntax + ;define-values + ;else + ;eof-object + ;error-object-irritants + ;error-object-message + ;error-object? + ;exact + ;exact-integer-sqrt + ;exact-integer? + ;exact? + ;features + ;file-error? + ;floor-quotient + ;floor-remainder + ;floor/ + ;flush-output-port + ;get-output-bytevector + ;get-output-string + ;guard + ;if + ;inexact + ;inexact? + ;input-port-open? + ;lambda + ;let*-values + ;let-syntax + ;let-values + ;letrec* + ;letrec-syntax + ;list-copy + ;list-set! + ;make-list + ;make-parameter + ;open-input-bytevector + ;open-input-string + ;open-output-bytevector + ;open-output-string + ;output-port-open? + ;parameterize + ;peek-u8 + ;port? + ;quote + ;raise + ;raise-continuable + ;read-bytevector + ;read-bytevector! + ;read-error? + ;read-line + ;read-string + ;read-u8 + ;set! + ;set-car! + ;set-cdr! + ;square + ;string->vector + ;string-copy! + ;string-fill! + ;string-for-each + ;string-map + ;string-set! + ;symbol=? + ;syntax-error + ;syntax-rules + ;textual-port? + ;truncate-quotient + ;truncate-remainder + ;truncate/ + ;u8-ready? + ;unless + ;unquote + ;unquote-splicing + ;vector->string + ;vector-append + ;vector-copy + ;vector-copy! + ;vector-fill! + ;vector-for-each + ;vector-map + ;vector-set! + ;when + ;with-exception-handler + ;write-bytevector + ;write-string + ;write-u8 + ) + (import (scheme r5rs))) diff --git a/lib/scheme/r5rs/char.sld b/lib/scheme/r5rs/char.sld new file mode 100644 --- /dev/null +++ b/lib/scheme/r5rs/char.sld @@ -0,0 +1,38 @@ +;;; +;;; husk-scheme +;;; http://justinethier.github.com/husk-scheme +;;; +;;; Written by Justin Ethier +;;; +;;; r5rs equivalent libraries +;;; +;;; This library exposes an R5RS equivalent to +;;; the corresponding R7RS-small library. +;;; + +(define-library (scheme r5rs char) + (export + char-alphabetic? + char-ci<=? + char-ci=? + char-ci>? + ;char-downcase + ;char-foldcase + char-lower-case? + char-numeric? + ;char-upcase + char-upper-case? + char-whitespace? + ;digit-value + string-ci<=? + string-ci=? + string-ci>? + ;string-downcase + ;string-foldcase + ;string-upcase + ) + (import (scheme r5rs))) diff --git a/lib/scheme/r5rs/complex.sld b/lib/scheme/r5rs/complex.sld new file mode 100644 --- /dev/null +++ b/lib/scheme/r5rs/complex.sld @@ -0,0 +1,22 @@ +;;; +;;; husk-scheme +;;; http://justinethier.github.com/husk-scheme +;;; +;;; Written by Justin Ethier +;;; +;;; r5rs equivalent libraries +;;; +;;; This library exposes an R5RS equivalent to +;;; the corresponding R7RS-small library. +;;; + +(define-library (scheme r5rs complex) + (export + angle + imag-part + magnitude + make-polar + make-rectangular + real-part + ) + (import (scheme r5rs))) diff --git a/lib/scheme/r5rs/cxr.sld b/lib/scheme/r5rs/cxr.sld new file mode 100644 --- /dev/null +++ b/lib/scheme/r5rs/cxr.sld @@ -0,0 +1,40 @@ +;;; +;;; husk-scheme +;;; http://justinethier.github.com/husk-scheme +;;; +;;; Written by Justin Ethier +;;; +;;; r5rs equivalent libraries +;;; +;;; This library exposes an R5RS equivalent to +;;; the corresponding R7RS-small library. +;;; + +(define-library (scheme r5rs cxr) + (export + caaaar + caaadr + caaar + caadar + caaddr + caadr + cadaar + cadadr + cadar + caddar + cadddr + caddr + cdaaar + cdaadr + cdaar + cdadar + cdaddr + cdadr + cddaar + cddadr + cddar + cdddar + cddddr + cdddr + ) + (import (scheme r5rs))) diff --git a/lib/scheme/r5rs/eval.sld b/lib/scheme/r5rs/eval.sld new file mode 100644 --- /dev/null +++ b/lib/scheme/r5rs/eval.sld @@ -0,0 +1,20 @@ +;;; +;;; husk-scheme +;;; http://justinethier.github.com/husk-scheme +;;; +;;; Written by Justin Ethier +;;; +;;; r5rs equivalent libraries +;;; +;;; This library exposes an R5RS equivalent to +;;; the corresponding R7RS-small library. +;;; + +(define-library (scheme r5rs eval) + (export + eval + current-environment + interaction-environment + make-environment + null-environment) + (import (scheme r5rs))) diff --git a/lib/scheme/r5rs/file.sld b/lib/scheme/r5rs/file.sld new file mode 100644 --- /dev/null +++ b/lib/scheme/r5rs/file.sld @@ -0,0 +1,26 @@ +;;; +;;; husk-scheme +;;; http://justinethier.github.com/husk-scheme +;;; +;;; Written by Justin Ethier +;;; +;;; r5rs equivalent libraries +;;; +;;; This library exposes an R5RS equivalent to +;;; the corresponding R7RS-small library. +;;; + +(define-library (scheme r5rs file) + (export + call-with-input-file + call-with-output-file + delete-file + file-exists? + ;open-binary-input-file + ;open-binary-output-file + open-input-file + open-output-file + ;with-input-from-file + ;with-output-to-file + ) + (import (scheme r5rs))) diff --git a/lib/scheme/r5rs/inexact.sld b/lib/scheme/r5rs/inexact.sld new file mode 100644 --- /dev/null +++ b/lib/scheme/r5rs/inexact.sld @@ -0,0 +1,28 @@ +;;; +;;; husk-scheme +;;; http://justinethier.github.com/husk-scheme +;;; +;;; Written by Justin Ethier +;;; +;;; r5rs equivalent libraries +;;; +;;; This library exposes an R5RS equivalent to +;;; the corresponding R7RS-small library. +;;; + +(define-library (scheme r5rs inexact) + (export + acos + asin + atan + cos + exp + ;finite? + ;infinite? + log + ;nan? + sin + sqrt + tan + ) + (import (scheme r5rs))) diff --git a/lib/scheme/r5rs/lazy.sld b/lib/scheme/r5rs/lazy.sld new file mode 100644 --- /dev/null +++ b/lib/scheme/r5rs/lazy.sld @@ -0,0 +1,21 @@ +;;; +;;; husk-scheme +;;; http://justinethier.github.com/husk-scheme +;;; +;;; Written by Justin Ethier +;;; +;;; r5rs equivalent libraries +;;; +;;; This library exposes an R5RS equivalent to +;;; the corresponding R7RS-small library. +;;; + +(define-library (scheme r5rs lazy) + (export + ;delay + ;delay-force + force + make-promise + ;promise? + ) + (import (scheme r5rs))) diff --git a/lib/scheme/r5rs/load.sld b/lib/scheme/r5rs/load.sld new file mode 100644 --- /dev/null +++ b/lib/scheme/r5rs/load.sld @@ -0,0 +1,15 @@ +;;; +;;; husk-scheme +;;; http://justinethier.github.com/husk-scheme +;;; +;;; Written by Justin Ethier +;;; +;;; r5rs equivalent libraries +;;; +;;; This library exposes an R5RS equivalent to +;;; the corresponding R7RS-small library. +;;; + +(define-library (scheme r5rs load) + (export load) + (import (scheme r5rs))) diff --git a/lib/scheme/r5rs/read.sld b/lib/scheme/r5rs/read.sld new file mode 100644 --- /dev/null +++ b/lib/scheme/r5rs/read.sld @@ -0,0 +1,15 @@ +;;; +;;; husk-scheme +;;; http://justinethier.github.com/husk-scheme +;;; +;;; Written by Justin Ethier +;;; +;;; r5rs equivalent libraries +;;; +;;; This library exposes an R5RS equivalent to +;;; the corresponding R7RS-small library. +;;; + +(define-library (scheme r5rs read) + (export read) + (import (scheme r5rs))) diff --git a/lib/scheme/r5rs/write.sld b/lib/scheme/r5rs/write.sld new file mode 100644 --- /dev/null +++ b/lib/scheme/r5rs/write.sld @@ -0,0 +1,20 @@ +;;; +;;; husk-scheme +;;; http://justinethier.github.com/husk-scheme +;;; +;;; Written by Justin Ethier +;;; +;;; r5rs equivalent libraries +;;; +;;; This library exposes an R5RS equivalent to +;;; the corresponding R7RS-small library. +;;; + +(define-library (scheme r5rs write) + (export + display + write + ; write-shared + ; write-simple + ) + (import (scheme r5rs))) diff --git a/lib/stdlib.scm b/lib/stdlib.scm --- a/lib/stdlib.scm +++ b/lib/stdlib.scm @@ -177,18 +177,59 @@ (define (assv obj alist) (foldl (mem-helper (curry eqv? obj) car) #f alist)) (define (assoc obj alist) (foldl (mem-helper (curry equal? obj) car) #f alist)) -; FUTURE: on map and for-each - Support variable number of args, per spec: -; http://www.schemers.org/Documents/Standards/R5RS/HTML/r5rs-Z-H-9.html#%_sec_6.4 -;(define (for-each func . lsts) ) +; SRFI 8 +; Reference implementation from: http://srfi.schemers.org/srfi-8/srfi-8.html +; +; FUTURE: This may be moved into its own file +; +(define-syntax receive + (syntax-rules () + ((receive formals expression body ...) + (call-with-values (lambda () expression) + (lambda formals body ...))))) +; END SRFI 8 -(define (for-each func lst) - (if (eq? 1 (length lst)) - (func (car lst)) - (begin (func (car lst)) - (for-each func (cdr lst))))) +; Added the following support functions from SRFI 1 +(define (car+cdr pair) (values (car pair) (cdr pair))) +(define (%cars+cdrs lists) + (call-with-current-continuation + (lambda (abort) + (let recur ((lists lists)) + (if (pair? lists) + (receive (list other-lists) (car+cdr lists) + (if (null? list) (abort '() '()) ; LIST is empty -- bail out + (receive (a d) (car+cdr list) + (receive (cars cdrs) (recur other-lists) + (values (cons a cars) (cons d cdrs)))))) + (values '() '())))))) +; END support functions -(define (map func lst) (foldr (lambda (x y) (cons (func x) y)) '() lst)) +(define (map f lis1 . lists) +; (check-arg procedure? f map-in-order) + (if (pair? lists) + (let recur ((lists (cons lis1 lists))) + (receive (cars cdrs) (%cars+cdrs lists) + (if (pair? cars) + (let ((x (apply f cars))) ; Do head first, + (cons x (recur cdrs))) ; then tail. + '()))) + ;; Fast path. + (foldr (lambda (x y) (cons (f x) y)) '() lis1))) +(define (for-each f lis1 . lists) + (if (pair? lists) + (let recur ((lists (cons lis1 lists))) + (receive (cars cdrs) (%cars+cdrs lists) + (if (pair? cars) + (begin + (apply f cars) + (recur cdrs))))) + ;; Fast path. + (if (eq? 1 (length lis1)) + (f (car lis1)) + (begin (f (car lis1)) + (for-each f (cdr lis1)))))) + (define (list-tail lst k) (if (zero? k) lst @@ -440,18 +481,6 @@ (set! gcd gcd/entry) (set! lcm lcm/entry)) - -; SRFI 8 -; Reference implementation from: http://srfi.schemers.org/srfi-8/srfi-8.html -; -; FUTURE: This may be moved into its own file -; -(define-syntax receive - (syntax-rules () - ((receive formals expression body ...) - (call-with-values (lambda () expression) - (lambda formals body ...))))) -; END SRFI 8 ; append accepts a variable number of arguments, per R5RS. So a wrapper ; has been provided for the standard 2-argument version of (append).