husk-scheme 3.6.2 → 3.6.3

raw patch · 12 files changed

+592/−68 lines, 12 filesdep +bytestringdep +utf8-stringPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: bytestring, utf8-string

API changes (from Hackage documentation)

Files

• ChangeLog.markdown +22/−0
• README.markdown +20/−0
• hs-src/Language/Scheme/Compiler.hs +61/−2
• hs-src/Language/Scheme/Core.hs +143/−9
• hs-src/Language/Scheme/Numerical.hs +101/−27
• hs-src/Language/Scheme/Parser.hs +38/−2
• hs-src/Language/Scheme/Plugins/CPUTime.hs +2/−2
• hs-src/Language/Scheme/Primitives.hs +88/−1
• hs-src/Language/Scheme/Types.hs +67/−18
• hs-src/Language/Scheme/Variables.hs +36/−5
• husk-scheme.cabal +2/−2
• lib/stdlib.scm +12/−0

@@ -1,3 +1,25 @@+v3.6.3+--------++Added support for R<sup>7</sup>RS bytevectors.++Added the Haskell function `evalLisp'` to evaluate a lisp data structure and return the `LispVal` or `LispError` result directly:++    evalLisp' :: Env -> LispVal -> IO (ThrowsError LispVal)++This makes it much easier to retrieve results when using husk as an extension language:++    result <- evalLisp' env $ List [Atom "/", Number 1, Number 0]+    case result of+      Left err -> putStrLn $ "Error: " ++ (show err)+      Right val -> putStrLn $ show val++Fixed a bug where setting a variable to refer back to itself would result in an infinite loop. For example, the last line of the following code would cause `huski` to hang:++    (define a '())+    (define b a)+    (define a b)+ v3.6.2 -------- This release adds support for nested quasi-quotation forms, which now respect depth level. This was done by replacing the quasi-quotation special form with a macro based on the one from chibi scheme. A nice side-benefit is that by removing the special forms, quasi-quotation now works in the compiler.

@@ -15,6 +15,26 @@     cabal update     cabal install husk-scheme +Before running husk you may also need to add the cabal executable directory to your path. On Linux this is `~/.cabal/bin`. Now you are ready to start up the interpreter:++    justin@my-pc$ huski+      _               _        __                 _                          +     | |             | |       \\\               | |                         +     | |__  _   _ ___| | __     \\\      ___  ___| |__   ___ _ __ ___   ___  +     | '_ \| | | / __| |/ /    //\\\    / __|/ __| '_ \ / _ \ '_ ` _ \ / _ \ +     | | | | |_| \__ \   <    /// \\\   \__ \ (__| | | |  __/ | | | | |  __/ +     |_| |_|\__,_|___/_|\_\  ///   \\\  |___/\___|_| |_|\___|_| |_| |_|\___| +                                                                             +     http://justinethier.github.com/husk-scheme                              +     (c) 2010-2012 Justin Ethier                                             +     Version 3.6.2 +                                                                             +    huski> (define (hello) 'world)+    (lambda () ...)+    huski> (hello)+    world+    huski>+ husk has been tested on Windows, Linux, and FreeBSD.  More information is available on the [husk website](http://justinethier.github.com/husk-scheme).

@@ -22,18 +22,20 @@ -}  module Language.Scheme.Compiler where -import qualified Language.Scheme.Core (apply, escapeBackslashes)+import qualified Language.Scheme.Core (apply, escapeBackslashes, evalLisp) import qualified Language.Scheme.Macro import Language.Scheme.Primitives import Language.Scheme.Types import Language.Scheme.Variables import Control.Monad.Error import qualified Data.Array+import qualified Data.ByteString as BS import Data.Complex import qualified Data.List import qualified Data.Map import Data.Ratio---import Debug.Trace+import Data.Word+-- import Debug.Trace  -- A type to store options passed to compile -- eventually all of this might be able to be integrated into a Compile monad@@ -110,6 +112,9 @@   let ls = Data.Array.elems v       size = (length ls) - 1   "Vector (listArray (0, " ++ show size ++ ")" ++ "[" ++ joinL (map ast2Str ls) "," ++ "])"+ast2Str (ByteVector bv) = do+  let ls = BS.unpack bv+  "ByteVector ( BS.pack " ++ "[" ++ joinL (map show ls) "," ++ "])" ast2Str (List ls) = "List [" ++ joinL (map ast2Str ls) "," ++ "]" ast2Str (DottedList ls l) =    "DottedList [" ++ joinL (map ast2Str ls) "," ++ "] $ " ++ ast2Str l@@ -129,9 +134,11 @@  , "Language.Scheme.Variables -- Scheme variable operations "  , "Control.Monad.Error "  , "Data.Array "+ , " qualified Data.ByteString as BS "  , "Data.Complex "  , " qualified Data.Map "  , "Data.Ratio "+ , "Data.Word "  , "System.IO "]  header :: String -> [String]@@ -209,6 +216,7 @@ compile _ (Bool b) copts = compileScalar ("  return $ Bool " ++ (show b)) copts -- TODO: eval env cont val@(HashTable _) = continueEval env cont val compile _ v@(Vector _) copts = compileScalar (" return $ " ++ ast2Str v) copts+compile _ v@(ByteVector _) copts = compileScalar (" return $ " ++ ast2Str v) copts compile _ ht@(HashTable _) copts = compileScalar (" return $ " ++ ast2Str ht) copts compile _ (Atom a) copts = do  c <- return $ createAstCont copts "val" ""@@ -219,6 +227,7 @@    AstValue $ "    DottedList _ _ -> Pointer \"" ++ a ++ "\" env",    AstValue $ "    String _ -> Pointer \"" ++ a ++ "\" env",    AstValue $ "    Vector _ -> Pointer \"" ++ a ++ "\" env",+   AstValue $ "    ByteVector _ -> Pointer \"" ++ a ++ "\" env",    AstValue $ "    HashTable _ -> Pointer \"" ++ a ++ "\" env",    AstValue $ "    _ -> v"], c] @@ -605,6 +614,30 @@ -- TODO: eval env cont args@(List [Atom "vector-set!" , nonvar , _ , _]) = do  -- TODO: eval env cont fargs@(List (Atom "vector-set!" : args)) = do  +compile env (List [Atom "bytevector-u8-set!", Atom var, i, object]) copts = do+ Atom symCompiledIdx <- _gensym "bytevectorSetIdx"+ Atom symCompiledObj <- _gensym "bytevectorSetObj"+ Atom symUpdateVec <- _gensym "bytevectorSetUpdate"+ Atom symIdxWrapper <- _gensym "bytevectorSetIdxWrapper"++ -- Entry point that allows this form to be redefined+ entryPt <- compileSpecialFormEntryPoint "bytevector-u8-set!" symCompiledIdx copts+ -- 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 " ]+ compiledObj <- compileExpr env object symCompiledObj Nothing+ -- Do actual update+ compiledUpdate <- return $ AstFunction symUpdateVec " env cont obj (Just [idx]) " [+    AstValue $ "  vec <- getVar env \"" ++ var ++ "\"",+    AstValue $ "  result <- updateByteVector vec idx obj >>= updateObject env \"" ++ var ++ "\"",+    createAstCont copts "result" ""]++ return $ [entryPt, compiledIdxWrapper, compiledUpdate] ++ compiledIdx ++ compiledObj++-- TODO: eval env cont args@(List [Atom "bytevector-u8-set!" , nonvar , _ , _]) = do +-- TODO: eval env cont fargs@(List (Atom "bytevector-u8-set!" : args)) = do + compile env (List [Atom "hash-table-set!", Atom var, rkey, rvalue]) copts = do  Atom symCompiledIdx <- _gensym "hashTableSetIdx"  Atom symCompiledObj <- _gensym "hashTableSetObj"@@ -648,6 +681,32 @@   return $ [entryPt, compiledUpdate] ++ compiledIdx -- TODO: eval env cont fargs@(List (Atom "hash-table-delete!" : args)) = do++-- TODO:+-- Testing this out; idea is to compile-in any code injected via load+compile env (List [Atom "load", filename, envSpec]) copts = do+  -- More TODO:+  -- Hacking around, the issue with require-extension / and-let* is that+  -- the compiler loads (and-let*) and attempts to compile the argument+  -- () which cannot be evaluated, hence the special form error on ()+  --+  -- LispEnv env+  y <- Language.Scheme.Core.evalLisp env envSpec+  -- TODO: I think this is no good because current-environment is really the+  -- same as env here. it would need to be evaluated and stored when it is first found+  -- hmm...not quite sure how to proceed here, need to think on it+  LispEnv env' <- Language.Scheme.Core.evalLisp env y+  compile env' (List [Atom "load", filename]) copts+compile env (List [Atom "load", Atom filename]) copts = do+  String filename' <- getVar env filename+  compile env (List [Atom "load", String filename']) copts+compile env (List [Atom "load", String filename]) copts = do -- TODO: allow filename from a var, support env optional arg+ Atom symEntryPt <- _gensym "load"+ result <- compileLisp env filename symEntryPt Nothing+ return $ result ++ +   [createAstFunc copts [+    AstValue $ "  result <- " ++ symEntryPt ++ " env (makeNullContinuation env) (Nil \"\") Nothing",+    createAstCont copts "result" ""]]  -- FUTURE: eventually it should be possible to evaluate the args instead of assuming -- that they are all strings, but lets keep it simple for now

@@ -16,6 +16,7 @@     (     -- * Scheme code evaluation       evalLisp+    , evalLisp'     , evalString     , evalAndPrint     , apply@@ -29,6 +30,7 @@     , showBanner     , substr     , updateVector+    , updateByteVector     ) where #ifdef UseFfi import qualified Language.Scheme.FFI@@ -41,15 +43,17 @@ import Language.Scheme.Variables import Control.Monad.Error import Data.Array+import qualified Data.ByteString as BS import qualified Data.Char import qualified Data.Map+import Data.Word import qualified System.Exit import System.IO--- import Debug.Trace+import Debug.Trace  -- |husk version number version :: String-version = "3.6.2"+version = "3.6.3"  -- |A utility function to display the husk console banner showBanner :: IO ()@@ -62,7 +66,7 @@   putStrLn " |_| |_|\\__,_|___/_|\\_\\  ///   \\\\\\  |___/\\___|_| |_|\\___|_| |_| |_|\\___| "   putStrLn "                                                                         "   putStrLn " http://justinethier.github.com/husk-scheme                              "-  putStrLn " (c) 2010-2012 Justin Ethier                                             "+  putStrLn " (c) 2010-2013 Justin Ethier                                             "   putStrLn $ " Version " ++ version ++ " "   putStrLn "                                                                         " @@ -88,9 +92,7 @@                    | otherwise =  x : xs   -{- |Evaluate a string containing Scheme code.--    For example:+{- |Evaluate a string containing Scheme code  @ env <- primitiveBindings@@ -113,12 +115,24 @@ evalAndPrint :: Env -> String -> IO () evalAndPrint env expr = evalString env expr >>= putStrLn --- |Evaluate lisp code that has already been loaded into haskell+-- |Evaluate a lisp data structure and return a value for use by husk evalLisp :: Env -> LispVal -> IOThrowsError LispVal evalLisp env lisp = do   v <- meval env (makeNullContinuation env) lisp   recDerefPtrs v +-- |Evaluate a lisp data structure and return the LispVal or LispError+--  result directly+-- +-- @+--  result <- evalLisp' env $ List [Atom "/", Number 1, Number 0]+--  case result of+--    Left err -> putStrLn $ "Error: " ++ (show err)+--    Right val -> putStrLn $ show val+-- @+evalLisp' :: Env -> LispVal -> IO (ThrowsError LispVal)+evalLisp' env lisp = runErrorT (evalLisp env lisp)+ -- |A wrapper for macroEval and eval meval, mprepareApply :: Env -> LispVal -> LispVal -> IOThrowsError LispVal meval env cont lisp = mfunc env cont lisp eval@@ -235,6 +249,7 @@ eval env cont val@(Bool _) = continueEval env cont val eval env cont val@(HashTable _) = continueEval env cont val eval env cont val@(Vector _) = continueEval env cont val+eval env cont val@(ByteVector _) = continueEval env cont val eval env cont val@(Pointer _ _) = continueEval env cont val eval env cont (Atom a) = do   v <- getVar env a@@ -244,6 +259,7 @@     DottedList _ _ -> Pointer a env     String _ -> Pointer a env     Vector _ -> Pointer a env+    ByteVector _ -> Pointer a env     HashTable _ -> Pointer a env #endif     _ -> v@@ -538,6 +554,35 @@   then prepareApply env cont fargs -- if is bound to a variable in this scope; call into it   else throwError $ NumArgs 3 args +eval env cont args@(List [Atom "bytevector-u8-set!", Atom var, i, object]) = do+ bound <- liftIO $ isRecBound env "bytevector-u8-set!"+ if bound+  then prepareApply env cont args -- if is bound to a variable in this scope; call into it+  else meval env (makeCPS env cont cpsObj) i+ where+        cpsObj :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal+        cpsObj e c idx _ = meval e (makeCPSWArgs e c cpsVec $ [idx]) object++        cpsVec :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal+        cpsVec e c obj (Just [idx]) = (meval e (makeCPSWArgs e c cpsUpdateVec $ [idx, obj]) =<< getVar e var)+        cpsVec _ _ _ _ = throwError $ InternalError "Invalid argument to cpsVec"++        cpsUpdateVec :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal+        cpsUpdateVec e c vec (Just [idx, obj]) =+            updateByteVector vec idx obj >>= updateObject e var >>= continueEval e c+        cpsUpdateVec _ _ _ _ = throwError $ InternalError "Invalid argument to cpsUpdateVec"++eval env cont args@(List [Atom "bytevector-u8-set!" , nonvar , _ , _]) = do + bound <- liftIO $ isRecBound env "bytevector-u8-set!"+ if bound+  then prepareApply env cont args -- if is bound to a variable in this scope; call into it+  else throwError $ TypeMismatch "variable" nonvar+eval env cont fargs@(List (Atom "bytevector-u8-set!" : args)) = do + bound <- liftIO $ isRecBound env "bytevector-u8-set!"+ if bound+  then prepareApply env cont fargs -- if is bound to a variable in this scope; call into it+  else throwError $ NumArgs 3 args+ eval env cont args@(List [Atom "hash-table-set!", Atom var, rkey, rvalue]) = do  bound <- liftIO $ isRecBound env "hash-table-set!"  if bound@@ -623,6 +668,20 @@   updateVector vec i obj updateVector v _ _ = throwError $ TypeMismatch "vector" v +-- |A helper function for the special form /(bytevector-u8-set!)/+updateByteVector :: LispVal -> LispVal -> LispVal -> IOThrowsError LispVal+updateByteVector (ByteVector vec) (Number idx) obj = +    case obj of+        Number byte -> do+-- TODO: error checking+           let (h, t) = BS.splitAt (fromInteger idx) vec+           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+  updateByteVector vec i obj+updateByteVector v _ _ = throwError $ TypeMismatch "bytevector" v+ {- Prepare for apply by evaluating each function argument,    and then execute the function via 'apply' -} prepareApply :: Env -> LispVal -> LispVal -> IOThrowsError LispVal@@ -654,7 +713,10 @@ prepareApply _ _ _ = throwError $ Default "Unexpected error in prepareApply"  -- |Call into a Scheme function-apply :: LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal+apply :: LispVal  -- ^ Current continuation+      -> LispVal  -- ^ Function or continuation to execute+      -> [LispVal] -- ^ Arguments+      -> IOThrowsError LispVal -- ^ Final value of computation apply _ cont@(Continuation env ccont ncont _ ndynwind) args = do -- case (trace ("calling into continuation. dynWind = " ++ show ndynwind) ndynwind) of   case ndynwind of@@ -764,7 +826,7 @@ -- evalfuncExitSuccess, evalfuncExitFail, evalfuncApply, evalfuncDynamicWind,    evalfuncEval, evalfuncLoad, evalfuncCallCC, evalfuncCallWValues,-  evalfuncMakeEnv, evalfuncNullEnv, evalfuncInteractionEnv :: [LispVal] -> IOThrowsError LispVal+  evalfuncMakeEnv, evalfuncNullEnv, evalfuncInteractionEnv, evalfuncImport :: [LispVal] -> IOThrowsError LispVal  {-  - A (somewhat) simplified implementation of dynamic-wind@@ -841,6 +903,61 @@ evalfuncInteractionEnv (cont@(Continuation env _ _ _ _) : _) = do     continueEval env cont $ LispEnv env +-- TODO: just testing out a binding for %import+-- evalfuncImport [+--     cont@(Continuation env _ _ _ _), +--     LispEnv toEnv,+--     LispEnv fromEnv, +--     List imports,+--     _] = do+-- --    topmostEnv <- liftIO $ topmostEnv toEnv -- TODO: testing this out; trying to overcome introducing vars to a nested env+--     LispEnv toEnv' <- getVar toEnv "meta-env"+--     result <- moduleImport toEnv' fromEnv imports+--     continueEval env cont (trace ("finished import") result)+-- +-- evalfuncImport [+--     cont@(Continuation env a b c d), +--     Bool False, -- Default to env+--     LispEnv fromEnv, +--     List imports,+--     _] = do+-- --    topmostEnv <- liftIO $ topmostEnv env -- TODO: testing this out; trying to overcome introducing vars to a nested env+--     LispEnv toEnv <- getVar env "meta-env"+--     LispEnv env' <- moduleImport toEnv fromEnv imports+--     continueEval+--         env'+--         (Continuation env' a b c d)+--         (trace ("finished import 2") $ LispEnv env')+-- -- TODO: should env' be passed along?    continueEval env' cont (trace ("finished import") $ LispEnv env')++evalfuncImport [+    cont@(Continuation env _ _ _ _), +    toEnv,+    LispEnv fromEnv, +    imports,+    _] = do+    let sourceEnv = case toEnv of+                        LispEnv e -> e+                        Bool False -> env++    LispEnv toEnv' <- getVar sourceEnv "meta-env"+    case imports of+        List i -> do+            result <- moduleImport toEnv' fromEnv i+            continueEval env cont (trace ("finished import") result)+-- TODO:        Bool False -> do -- Export everything (?)++-- This is just for debugging purposes:+evalfuncImport (cont@(Continuation env _ _ _ _ ) : cs) = do+    (trace ("import DEBUG: " ++ show cs) continueEval) env cont $ Nil ""++moduleImport to from (Atom i : is) = do+  v <- getVar from i +  _ <- defineVar to i (trace ("Import toEnv: " ++ "[" ++ i ++ "]" ++ show v) v)+  moduleImport to from is+moduleImport to from [] = do+  return $ LispEnv to+ evalfuncLoad [cont@(Continuation _ a b c d), String filename, LispEnv env] = do     evalfuncLoad [Continuation env a b c d, String filename] @@ -917,6 +1034,7 @@                   , ("null-environment", evalfuncNullEnv)                   , ("current-environment", evalfuncInteractionEnv)                   , ("interaction-environment", evalfuncInteractionEnv)+                  , ("%import", evalfuncImport)                   , ("make-environment", evalfuncMakeEnv)                 -- Non-standard extensions@@ -964,10 +1082,16 @@                 ("delete-file", deleteFile),                  -- Other I/O functions+                ("print-env", printEnv'),                 ("read-contents", readContents),                 ("read-all", readAll),                 ("gensym", gensym)] +printEnv' :: [LispVal] -> IOThrowsError LispVal+printEnv' [LispEnv env] = do+    result <- liftIO $ printEnv env+    return $ String result+ {- "Pure" primitive functions -} primitives :: [(String, [LispVal] -> ThrowsError LispVal)] primitives = [("+", numAdd),@@ -1079,6 +1203,16 @@               ("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),

@@ -11,10 +11,8 @@ -}  module Language.Scheme.Numerical (-   numericBinop--- , foldlM--- , foldl1M- , numSub+ -- * Generic functions+   numSub  , numMul  , numDiv  , numAdd@@ -26,20 +24,30 @@  , numBoolBinopLt  , numBoolBinopLte  , numCast+ , numDenominator+ , numNumerator+ , numInexact2Exact+ , numExact2Inexact + , num2String+ , unpackNum+ , numericBinop+ -- * Floating point functions  , numFloor  , numCeiling  , numTruncate  , numRound+ , numExpt+ , numSqrt+ , numExp+ , numLog+ -- * Trigonometric functions  , numSin  , numCos  , numTan  , numAsin   , numAcos  , numAtan- , numExpt- , numSqrt- , numExp- , numLog+ -- * Complex functions  , buildComplex  , numMakePolar  , numRealPart@@ -47,18 +55,13 @@  , numMagnitude  , numAngle  , numMakeRectangular- , numDenominator- , numNumerator- , numInexact2Exact- , numExact2Inexact - , num2String+ -- * Predicates  , isComplex  , isReal   , isRational  , isInteger  , isNumber  , isFloatAnInteger- , unpackNum ) where import Language.Scheme.Types @@ -70,6 +73,7 @@ import Numeric import Text.Printf +-- |A helper function to perform a numeric operation on two values numericBinop :: (Integer -> Integer -> Integer) -> [LispVal] -> ThrowsError LispVal numericBinop _ singleVal@[_] = throwError $ NumArgs 2 singleVal numericBinop op aparams = mapM unpackNum aparams >>= return . Number . foldl1 op@@ -89,8 +93,8 @@ numerical types they accept. Within reason, a user should not have to know what numerical type they are passing when using these functions -} --numAdd, numSub, numMul, numDiv, numMod :: [LispVal] -> ThrowsError LispVal+-- |Add the given numbers+numAdd :: [LispVal] -> ThrowsError LispVal numAdd [] = return $ Number 0 numAdd aparams = do   foldl1M (\ a b -> doAdd =<< (numCast [a, b])) aparams@@ -99,6 +103,9 @@         doAdd (List [(Rational a), (Rational b)]) = return $ Rational $ a + b         doAdd (List [(Complex a), (Complex b)]) = return $ Complex $ a + b         doAdd _ = throwError $ Default "Unexpected error in +"++-- |Subtract the given numbers+numSub :: [LispVal] -> ThrowsError LispVal numSub [] = throwError $ NumArgs 1 [] numSub [Number n] = return $ Number $ -1 * n numSub [Float n] = return $ Float $ -1 * n@@ -111,6 +118,9 @@         doSub (List [(Rational a), (Rational b)]) = return $ Rational $ a - b         doSub (List [(Complex a), (Complex b)]) = return $ Complex $ a - b         doSub _ = throwError $ Default "Unexpected error in -"++-- |Multiply the given numbers+numMul :: [LispVal] -> ThrowsError LispVal numMul [] = return $ Number 1 numMul aparams = do   foldl1M (\ a b -> doMul =<< (numCast [a, b])) aparams@@ -119,6 +129,9 @@         doMul (List [(Rational a), (Rational b)]) = return $ Rational $ a * b         doMul (List [(Complex a), (Complex b)]) = return $ Complex $ a * b         doMul _ = throwError $ Default "Unexpected error in *"++-- |Divide the given numbers+numDiv :: [LispVal] -> ThrowsError LispVal numDiv [] = throwError $ NumArgs 1 [] numDiv [Number 0] = throwError $ DivideByZero  numDiv [Rational 0] = throwError $ DivideByZero  @@ -145,6 +158,8 @@                                                        else return $ Complex $ a / b         doDiv _ = throwError $ Default "Unexpected error in /" +-- |Take the modulus of the given numbers+numMod :: [LispVal] -> ThrowsError LispVal numMod [] = return $ Number 1 numMod aparams = do   foldl1M (\ a b -> doMod =<< (numCast [a, b])) aparams@@ -154,6 +169,7 @@         doMod (List [(Complex _), (Complex _)]) = throwError $ Default "modulo not implemented for complex numbers"          doMod _ = throwError $ Default "Unexpected error in modulo" +-- |Numeric equals numBoolBinopEq :: [LispVal] -> ThrowsError LispVal numBoolBinopEq [] = throwError $ NumArgs 0 [] numBoolBinopEq aparams = do@@ -164,6 +180,7 @@         doOp (List [(Complex a), (Complex b)]) = return $ Bool $ a == b         doOp _ = throwError $ Default "Unexpected error in =" +-- |Numeric greater than numBoolBinopGt :: [LispVal] -> ThrowsError LispVal numBoolBinopGt [] = throwError $ NumArgs 0 [] numBoolBinopGt aparams = do@@ -173,6 +190,7 @@         doOp (List [(Rational a), (Rational b)]) = return $ Bool $ a > b         doOp _ = throwError $ Default "Unexpected error in >" +-- |Numeric greater than equal numBoolBinopGte :: [LispVal] -> ThrowsError LispVal numBoolBinopGte [] = throwError $ NumArgs 0 [] numBoolBinopGte aparams = do@@ -182,6 +200,7 @@         doOp (List [(Rational a), (Rational b)]) = return $ Bool $ a >= b         doOp _ = throwError $ Default "Unexpected error in >=" +-- |Numeric less than  numBoolBinopLt :: [LispVal] -> ThrowsError LispVal numBoolBinopLt [] = throwError $ NumArgs 0 [] numBoolBinopLt aparams = do@@ -191,6 +210,7 @@         doOp (List [(Rational a), (Rational b)]) = return $ Bool $ a < b         doOp _ = throwError $ Default "Unexpected error in <" +-- |Numeric less than equal numBoolBinopLte :: [LispVal] -> ThrowsError LispVal numBoolBinopLte [] = throwError $ NumArgs 0 [] numBoolBinopLte aparams = do@@ -200,6 +220,7 @@         doOp (List [(Rational a), (Rational b)]) = return $ Bool $ a <= b         doOp _ = throwError $ Default "Unexpected error in <=" +-- |Accept two numbers and cast one of them to the appropriate type, if necessary numCast :: [LispVal] -> ThrowsError LispVal numCast [a@(Number _), b@(Number _)] = return $ List [a, b] numCast [a@(Float _), b@(Float _)] = return $ List [a, b]@@ -226,6 +247,7 @@   where doThrowError num = throwError $ TypeMismatch "number" num numCast _ = throwError $ Default "Unexpected error in numCast" +-- |Convert the given number to a rational numRationalize :: [LispVal] -> ThrowsError LispVal numRationalize [(Number n)] = return $ Rational $ toRational n numRationalize [(Float n)] = return $ Rational $ toRational n@@ -233,7 +255,8 @@ numRationalize [x] = throwError $ TypeMismatch "number" x numRationalize badArgList = throwError $ NumArgs 1 badArgList -numRound, numFloor, numCeiling, numTruncate :: [LispVal] -> ThrowsError LispVal+-- |Round the given number+numRound :: [LispVal] -> ThrowsError LispVal numRound [n@(Number _)] = return n numRound [(Rational n)] = return $ Number $ round n numRound [(Float n)] = return $ Float $ fromInteger $ round n@@ -242,6 +265,8 @@ numRound [x] = throwError $ TypeMismatch "number" x numRound badArgList = throwError $ NumArgs 1 badArgList +-- |Floor the given number+numFloor :: [LispVal] -> ThrowsError LispVal numFloor [n@(Number _)] = return n numFloor [(Rational n)] = return $ Number $ floor n numFloor [(Float n)] = return $ Float $ fromInteger $ floor n@@ -250,6 +275,8 @@ numFloor [x] = throwError $ TypeMismatch "number" x numFloor badArgList = throwError $ NumArgs 1 badArgList +-- |Take the ceiling of the given number+numCeiling :: [LispVal] -> ThrowsError LispVal numCeiling [n@(Number _)] = return n numCeiling [(Rational n)] = return $ Number $ ceiling n numCeiling [(Float n)] = return $ Float $ fromInteger $ ceiling n@@ -258,6 +285,8 @@ numCeiling [x] = throwError $ TypeMismatch "number" x numCeiling badArgList = throwError $ NumArgs 1 badArgList +-- |Truncate the given number+numTruncate :: [LispVal] -> ThrowsError LispVal numTruncate [n@(Number _)] = return n numTruncate [(Rational n)] = return $ Number $ truncate n numTruncate [(Float n)] = return $ Float $ fromInteger $ truncate n@@ -266,7 +295,7 @@ numTruncate [x] = throwError $ TypeMismatch "number" x numTruncate badArgList = throwError $ NumArgs 1 badArgList -+-- |Sine numSin :: [LispVal] -> ThrowsError LispVal numSin [(Number n)] = return $ Float $ sin $ fromInteger n numSin [(Float n)] = return $ Float $ sin n@@ -275,6 +304,7 @@ numSin [x] = throwError $ TypeMismatch "number" x numSin badArgList = throwError $ NumArgs 1 badArgList +-- |Cosine numCos :: [LispVal] -> ThrowsError LispVal numCos [(Number n)] = return $ Float $ cos $ fromInteger n numCos [(Float n)] = return $ Float $ cos n@@ -283,6 +313,7 @@ numCos [x] = throwError $ TypeMismatch "number" x numCos badArgList = throwError $ NumArgs 1 badArgList +-- |Tangent numTan :: [LispVal] -> ThrowsError LispVal numTan [(Number n)] = return $ Float $ tan $ fromInteger n numTan [(Float n)] = return $ Float $ tan n@@ -291,6 +322,7 @@ numTan [x] = throwError $ TypeMismatch "number" x numTan badArgList = throwError $ NumArgs 1 badArgList +-- |Arcsine numAsin :: [LispVal] -> ThrowsError LispVal numAsin [(Number n)] = return $ Float $ asin $ fromInteger n numAsin [(Float n)] = return $ Float $ asin n@@ -299,6 +331,7 @@ numAsin [x] = throwError $ TypeMismatch "number" x numAsin badArgList = throwError $ NumArgs 1 badArgList +-- |Arccosine numAcos :: [LispVal] -> ThrowsError LispVal numAcos [(Number n)] = return $ Float $ acos $ fromInteger n numAcos [(Float n)] = return $ Float $ acos n@@ -307,6 +340,7 @@ numAcos [x] = throwError $ TypeMismatch "number" x numAcos badArgList = throwError $ NumArgs 1 badArgList +-- |Arctangent numAtan :: [LispVal] -> ThrowsError LispVal numAtan [(Number n)] = return $ Float $ atan $ fromInteger n numAtan [Number y, Number x] = return $ Float $ phase $ (fromInteger x) :+ (fromInteger y)@@ -318,7 +352,8 @@ numAtan [x] = throwError $ TypeMismatch "number" x numAtan badArgList = throwError $ NumArgs 1 badArgList -numSqrt, numExpt :: [LispVal] -> ThrowsError LispVal+-- |Take the square root of the given number+numSqrt :: [LispVal] -> ThrowsError LispVal numSqrt [(Number n)] = if n >= 0 then return $ Float $ sqrt $ fromInteger n                                  else return $ Complex $ sqrt ((fromInteger n) :+ 0) numSqrt [(Float n)] = if n >= 0 then return $ Float $ sqrt n@@ -328,6 +363,8 @@ numSqrt [x] = throwError $ TypeMismatch "number" x numSqrt badArgList = throwError $ NumArgs 1 badArgList +-- |Raise the first number to the power of the second+numExpt :: [LispVal] -> ThrowsError LispVal numExpt [(Number n), (Number p)] = return $ Float $ (fromInteger n) ^ p numExpt [(Rational n), (Number p)] = return $ Float $ (fromRational n) ^ p numExpt [(Float n), (Number p)] = return $ Float $ n ^ p@@ -342,6 +379,7 @@         doExpt (List [(Float a), (Float b)]) = return $ Float $ a ^ b --        doExpt (List [(Complex a), (Complex b)]) = return $ Complex $ a ^ b -} +-- |Take the exponent of the given number numExp :: [LispVal] -> ThrowsError LispVal numExp [(Number n)] = return $ Float $ exp $ fromInteger n numExp [(Float n)] = return $ Float $ exp n@@ -350,6 +388,7 @@ numExp [x] = throwError $ TypeMismatch "number" x numExp badArgList = throwError $ NumArgs 1 badArgList +-- |Compute the log of a given number numLog :: [LispVal] -> ThrowsError LispVal numLog [(Number n)] = return $ Float $ log $ fromInteger n numLog [(Float n)] = return $ Float $ log n@@ -358,8 +397,15 @@ numLog [x] = throwError $ TypeMismatch "number" x numLog badArgList = throwError $ NumArgs 1 badArgList +-- Complex number functions -buildComplex :: LispVal -> LispVal -> ThrowsError LispVal+-- |Create a complex number+buildComplex :: LispVal +             -- ^ Real part+             -> LispVal +             -- ^ Imaginary part+             -> ThrowsError LispVal+             -- ^ Complex number buildComplex (Number x) (Number y) = return $ Complex $ (fromInteger x) :+ (fromInteger y) buildComplex (Number x) (Rational y) = return $ Complex $ (fromInteger x) :+ (fromRational y) buildComplex (Number x) (Float y) = return $ Complex $ (fromInteger x) :+ y@@ -371,48 +417,60 @@ buildComplex (Float x) (Float y) = return $ Complex $ x :+ y buildComplex x y = throwError $ TypeMismatch "number" $ List [x, y] --- Complex number functions-numMakeRectangular, numMakePolar, numRealPart, numImagPart, numMagnitude, numAngle :: [LispVal] -> ThrowsError LispVal+-- |Create a complex number given its real and imaginary parts+numMakeRectangular :: [LispVal] -> ThrowsError LispVal numMakeRectangular [x, y] = buildComplex x y numMakeRectangular badArgList = throwError $ NumArgs 2 badArgList +-- |Create a complex number from its magnitude and phase (angle)+numMakePolar :: [LispVal] -> ThrowsError LispVal numMakePolar [(Float x), (Float y)] = return $ Complex $ mkPolar x y numMakePolar [(Float _), y] = throwError $ TypeMismatch "real" y numMakePolar [x, (Float _)] = throwError $ TypeMismatch "real real" $ x numMakePolar badArgList = throwError $ NumArgs 2 badArgList +-- |The phase of a complex number+numAngle :: [LispVal] -> ThrowsError LispVal numAngle [(Complex c)] = return $ Float $ phase c numAngle [x] = throwError $ TypeMismatch "complex number" x numAngle badArgList = throwError $ NumArgs 1 badArgList +-- |The nonnegative magnitude of a complex number+numMagnitude :: [LispVal] -> ThrowsError LispVal numMagnitude [(Complex c)] = return $ Float $ magnitude c numMagnitude [x] = throwError $ TypeMismatch "complex number" x numMagnitude badArgList = throwError $ NumArgs 1 badArgList +-- |Retrieve real part of a complex number+numRealPart :: [LispVal] -> ThrowsError LispVal numRealPart [(Complex c)] = return $ Float $ realPart c numRealPart [x] = throwError $ TypeMismatch "complex number" x numRealPart badArgList = throwError $ NumArgs 1 badArgList +-- |Retrieve imaginary part of a complex number+numImagPart :: [LispVal] -> ThrowsError LispVal numImagPart [(Complex c)] = return $ Float $ imagPart c numImagPart [x] = throwError $ TypeMismatch "complex number" x numImagPart badArgList = throwError $ NumArgs 1 badArgList --numNumerator, numDenominator :: [LispVal] -> ThrowsError LispVal+-- |Take the numerator of the given number+numNumerator :: [LispVal] -> ThrowsError LispVal numNumerator [n@(Number _)] = return n numNumerator [(Rational r)] = return $ Number $ numerator r numNumerator [(Float f)] = return $ Float $ fromInteger . numerator . toRational $ f---numNumerator [(Float f)] = return $ Float $ fromInteger $ numerator $ toRational f numNumerator [x] = throwError $ TypeMismatch "rational number" x numNumerator badArgList = throwError $ NumArgs 1 badArgList +-- |Take the denominator of the given number+numDenominator :: [LispVal] -> ThrowsError LispVal numDenominator [Number _] = return $ Number 1 numDenominator [(Rational r)] = return $ Number $ denominator r numDenominator [(Float f)] = return $ Float $ fromInteger $ denominator $ toRational f numDenominator [x] = throwError $ TypeMismatch "rational number" x numDenominator badArgList = throwError $ NumArgs 1 badArgList -numExact2Inexact, numInexact2Exact :: [LispVal] -> ThrowsError LispVal+-- |Convert an exact number to inexact+numExact2Inexact :: [LispVal] -> ThrowsError LispVal numExact2Inexact [(Number n)] = return $ Float $ fromInteger n numExact2Inexact [(Rational n)] = return $ Float $ fromRational n numExact2Inexact [n@(Float _)] = return n@@ -420,6 +478,8 @@ numExact2Inexact [badType] = throwError $ TypeMismatch "number" badType numExact2Inexact badArgList = throwError $ NumArgs 1 badArgList +-- |Convert an inexact number to exact+numInexact2Exact :: [LispVal] -> ThrowsError LispVal numInexact2Exact [n@(Number _)] = return n numInexact2Exact [n@(Rational _)] = return n numInexact2Exact [(Float n)] = return $ Number $ round n@@ -444,31 +504,45 @@ num2String [x] = throwError $ TypeMismatch "number" x num2String badArgList = throwError $ NumArgs 1 badArgList -isNumber, isComplex, isReal, isRational, isInteger :: [LispVal] -> ThrowsError LispVal+-- |Predicate to determine if given value is a number+isNumber :: [LispVal] -> ThrowsError LispVal isNumber ([Number _]) = return $ Bool True isNumber ([Float _]) = return $ Bool True isNumber ([Complex _]) = return $ Bool True isNumber ([Rational _]) = return $ Bool True isNumber _ = return $ Bool False +-- |Predicate to determine if given number is complex.+--  Keep in mind this does not just look at the types +isComplex :: [LispVal] -> ThrowsError LispVal isComplex ([Complex _]) = return $ Bool True isComplex ([Number _]) = return $ Bool True isComplex ([Rational _]) = return $ Bool True isComplex ([Float _]) = return $ Bool True isComplex _ = return $ Bool False +-- |Predicate to determine if given number is a real.+--  Keep in mind this does not just look at the types +isReal :: [LispVal] -> ThrowsError LispVal isReal ([Number _]) = return $ Bool True isReal ([Rational _]) = return $ Bool True isReal ([Float _]) = return $ Bool True isReal ([Complex c]) = return $ Bool $ (imagPart c) == 0 isReal _ = return $ Bool False +-- |Predicate to determine if given number is a rational.+--  Keep in mind this does not just look at the types +isRational :: [LispVal] -> ThrowsError LispVal isRational ([Number _]) = return $ Bool True isRational ([Rational _]) = return $ Bool True isRational ([n@(Float _)]) = return $ Bool $ isFloatAnInteger n                              -- FUTURE: not quite good enough, could be represented exactly and not an integer isRational _ = return $ Bool False +-- |Predicate to determine if given number is an integer.+--  Keep in mind this does not just look at the types; +--  a floating point input value can return true, for example.+isInteger :: [LispVal] -> ThrowsError LispVal isInteger ([Number _]) = return $ Bool True isInteger ([Complex n]) = do   return $ Bool $ (isFloatAnInteger $ Float $ realPart n) && (isFloatAnInteger $ Float $ imagPart n)

@@ -20,7 +20,6 @@     , readExpr     , readExprList      -- *Low level parsing-    , symbol     , parseExpr      , parseAtom     , parseBool@@ -36,6 +35,7 @@     , parseEscapedChar      , parseString      , parseVector+    , parseByteVector     , parseHashTable     , parseList     , parseDottedList@@ -47,10 +47,12 @@ import Language.Scheme.Types import Control.Monad.Error import Data.Array+import qualified Data.ByteString as BS import qualified Data.Char as Char import Data.Complex-import Data.Ratio import qualified Data.Map+import Data.Ratio+import Data.Word import Numeric import Text.ParserCombinators.Parsec hiding (spaces) import Text.Parsec.Language@@ -100,9 +102,11 @@ --lexeme :: ParsecT String () Identity a -> ParsecT String () Identity a lexeme = P.lexeme lexer +-- |Match a special character symbol :: Parser Char symbol = oneOf "!$%&|*+-/:<=>?@^_~." +-- |Parse an atom (scheme symbol) parseAtom :: Parser LispVal parseAtom = do   atom <- identifier@@ -110,6 +114,7 @@      then pzero -- Do not match this form      else return $ Atom atom +-- |Parse a boolean parseBool :: Parser LispVal parseBool = do _ <- string "#"                x <- oneOf "tf"@@ -118,6 +123,7 @@                           'f' -> Bool False                           _ -> Bool False +-- |Parse a character parseChar :: Parser LispVal parseChar = do   _ <- try (string "#\\")@@ -129,6 +135,8 @@     "newline" -> Char '\n'     _ -> Char c ++-- |Parse an integer in octal notation, base 8 parseOctalNumber :: Parser LispVal parseOctalNumber = do   _ <- try (string "#o")@@ -139,6 +147,7 @@      1 -> return $ Number $ fromInteger $ (*) (-1) $ fst $ Numeric.readOct num !! 0      _ -> pzero +-- |Parse an integer in binary notation, base 2 parseBinaryNumber :: Parser LispVal parseBinaryNumber = do   _ <- try (string "#b")@@ -149,6 +158,7 @@      1 -> return $ Number $ fromInteger $ (*) (-1) $ fst $ Numeric.readInt 2 (`elem` "01") Char.digitToInt num !! 0      _ -> pzero +-- |Parse an integer in hexadecimal notation, base 16 parseHexNumber :: Parser LispVal parseHexNumber = do   _ <- try (string "#x")@@ -224,6 +234,7 @@   buildResult (Float num) nexp = return $ Float $ num * (10 ** (fromIntegral nexp))   buildResult _ _ = pzero +-- |Parse a rational number parseRationalNumber :: Parser LispVal parseRationalNumber = do   pnumerator <- parseDecimalNumber@@ -241,6 +252,7 @@                 else return $ Rational $ n % pdenominator     _ -> pzero +-- |Parse a complex number parseComplexNumber :: Parser LispVal parseComplexNumber = do   lispreal <- (try (parseRealNumber) <|> try (parseRationalNumber) <|> parseDecimalNumber)@@ -259,6 +271,7 @@   _ <- char 'i'   return $ Complex $ real :+ imag +-- |Parse an escaped character parseEscapedChar :: forall st .                     GenParser Char st Char parseEscapedChar = do@@ -270,6 +283,7 @@     'r' -> '\r'     _ -> c +-- |Parse a string parseString :: Parser LispVal parseString = do   _ <- char '"'@@ -277,11 +291,21 @@   _ <- char '"'   return $ String x +-- |Parse a vector parseVector :: Parser LispVal parseVector = do   vals <- sepBy parseExpr whiteSpace   return $ Vector (listArray (0, (length vals - 1)) vals) +-- |Parse a bytevector+parseByteVector :: Parser LispVal+parseByteVector = do+  ns <- sepBy parseNumber whiteSpace+  return $ ByteVector $ BS.pack $ map conv ns+ where +   conv (Number n) = fromInteger n :: Word8+   conv n = 0 :: Word8+ -- |Parse a hash table. The table is either empty or is made up of --  an alist (associative list) parseHashTable :: Parser LispVal@@ -302,10 +326,12 @@     Just m -> return $ HashTable $ Data.Map.fromList m     Nothing -> pzero +-- |Parse a list parseList :: Parser LispVal parseList = liftM List $ sepBy parseExpr whiteSpace -- TODO: wanted to use endBy (or a variant) above, but it causes an error such that dotted lists are not parsed +-- |Parse a dotted list (scheme pair) parseDottedList :: Parser LispVal parseDottedList = do   phead <- endBy parseExpr whiteSpace@@ -333,24 +359,29 @@        all of R5RS without performing this transformation. -}     _ -> return $ DottedList phead ptail +-- |Parse a quoted expression parseQuoted :: Parser LispVal parseQuoted = do   _ <- lexeme $ char '\''   x <- parseExpr   return $ List [Atom "quote", x] +-- |Parse a quasi-quoted expression parseQuasiQuoted :: Parser LispVal parseQuasiQuoted = do   _ <- lexeme $ char '`'   x <- parseExpr   return $ List [Atom "quasiquote", x] +-- |Parse an unquoted expression (a quasiquotated expression preceded+--  by a comma) parseUnquoted :: Parser LispVal parseUnquoted = do   _ <- try (lexeme $ char ',')   x <- parseExpr   return $ List [Atom "unquote", x] +-- |Parse an unquote-spliced expression parseUnquoteSpliced :: Parser LispVal parseUnquoteSpliced = do   _ <- try (lexeme $ string ",@")@@ -374,6 +405,10 @@          x <- parseVector          _ <- lexeme $ char ')'          return x+  <|> do _ <- try (lexeme $ string "#u8(")+         x <- parseByteVector+         _ <- lexeme $ char ')'+         return x --  <|> do _ <- try (lexeme $ string "#hash(") --         x <- parseHashTable --         _ <- lexeme $ char ')'@@ -390,6 +425,7 @@   <|> brackets parseDottedList   <?> "Expression" +-- |Initial parser used by the high-level parse functions mainParser :: Parser LispVal mainParser = do     _ <- whiteSpace

@@ -22,14 +22,14 @@ import System.CPUTime import Control.Monad.Error -get, precision :: [LispVal] -> IOThrowsError LispVal- -- |Wrapper for CPUTime.getCPUTime+get :: [LispVal] -> IOThrowsError LispVal get [] = do   t <- liftIO $ System.CPUTime.getCPUTime   return $ Number t get badArgList = throwError $ NumArgs 0 badArgList  -- |Wrapper for CPUTime.cpuTimePrecision+precision :: [LispVal] -> IOThrowsError LispVal precision [] = return $ Number $ System.CPUTime.cpuTimePrecision precision badArgList = throwError $ NumArgs 0 badArgList

@@ -29,6 +29,15 @@  , vectorToList   , listToVector  , makeVector+ -- ** Bytevectors+ , makeByteVector+ , byteVector+ , byteVectorLength+ , byteVectorRef+ , byteVectorCopy+ , byteVectorAppend+ , byteVectorUtf2Str+ , byteVectorStr2Utf  -- ** Hash Table  , hashTblExists   , hashTblRef@@ -73,9 +82,11 @@  , isProcedure   , isList   , isVector + , isByteVector  , isNull   , isEOFObject   , isSymbol +  -- ** Utility functions  , unpackEquals   , boolBinop @@ -114,10 +125,13 @@ import Language.Scheme.Types --import qualified Control.Exception import Control.Monad.Error+import qualified Data.ByteString as BS+import qualified Data.ByteString.UTF8 as BSU import Data.Char hiding (isSymbol) import Data.Array import Data.Unique import qualified Data.Map+import Data.Word import System.IO import System.Directory (doesFileExist, removeFile) import System.IO.Error@@ -319,7 +333,11 @@ vectorLength [badType] = throwError $ TypeMismatch "vector" badType vectorLength badArgList = throwError $ NumArgs 1 badArgList -vectorRef [(Vector v), (Number n)] = return $ v ! (fromInteger n)+vectorRef [(Vector v), (Number n)] = do+    let len = toInteger $ (length $ elems v) - 1+    if n > len || n < 0+       then throwError $ Default "Invalid index"+       else return $ v ! (fromInteger n) vectorRef [badType] = throwError $ TypeMismatch "vector integer" badType vectorRef badArgList = throwError $ NumArgs 2 badArgList @@ -331,6 +349,71 @@ listToVector [badType] = throwError $ TypeMismatch "list" badType listToVector badArgList = throwError $ NumArgs 1 badArgList +-- ------------ Bytevector Primitives --------------+makeByteVector, byteVector, byteVectorLength, byteVectorRef, byteVectorCopy, byteVectorAppend, byteVectorUtf2Str, byteVectorStr2Utf :: [LispVal] -> ThrowsError LispVal+makeByteVector [(Number n)] = do+  let ls = replicate (fromInteger n) (0 :: Word8)+  return $ ByteVector $ BS.pack ls+makeByteVector [Number n, Number byte] = do+  let ls = replicate (fromInteger n) (fromInteger byte :: Word8)+  return $ ByteVector $ BS.pack ls+makeByteVector [badType] = throwError $ TypeMismatch "integer" badType+makeByteVector badArgList = throwError $ NumArgs 2 badArgList++byteVector bs = do+ return $ ByteVector $ BS.pack $ map conv bs+ where +   conv (Number n) = fromInteger n :: Word8+   conv n = 0 :: Word8++byteVectorCopy [ByteVector bv] = do+    return $ ByteVector $ BS.copy+        bv+byteVectorCopy [ByteVector bv, Number start] = do+    return $ ByteVector $ BS.drop +        (fromInteger start)+        bv+byteVectorCopy [ByteVector bv, Number start, Number end] = do+    return $ ByteVector $ BS.take +        (fromInteger $ end - start)+        (BS.drop +            (fromInteger start)+            bv)+byteVectorCopy [badType] = throwError $ TypeMismatch "bytevector" badType+byteVectorCopy badArgList = throwError $ NumArgs 1 badArgList++byteVectorAppend bs = do+    let acc = BS.pack []+        conv (ByteVector bs) = bs+        conv x = BS.empty+        bs' = map conv bs+    return $ ByteVector $ BS.concat bs'+-- TODO: error handling++byteVectorLength [(ByteVector bv)] = return $ Number $ toInteger $ BS.length bv+byteVectorLength [badType] = throwError $ TypeMismatch "bytevector" badType+byteVectorLength badArgList = throwError $ NumArgs 1 badArgList++byteVectorRef [(ByteVector bv), (Number n)] = do+    let len = toInteger $ (BS.length bv) - 1+    if n > len || n < 0+       then throwError $ Default "Invalid index"+       else return $ Number $ toInteger $ BS.index bv (fromInteger n)+byteVectorRef [badType] = throwError $ TypeMismatch "bytevector integer" badType+byteVectorRef badArgList = throwError $ NumArgs 2 badArgList++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 1 badArgList+byteVectorStr2Utf [(String s)] = do+    return $ ByteVector $ BSU.fromString s+-- TODO: need to support other overloads of this function+byteVectorStr2Utf [badType] = throwError $ TypeMismatch "string" badType+byteVectorStr2Utf badArgList = throwError $ NumArgs 1 badArgList++ -- ------------ Hash Table Primitives --------------  -- Future: support (equal?), (hash) parameters@@ -515,6 +598,10 @@ isVector _ = return $ Bool False isList (List _) = return $ Bool True isList _ = return $ Bool False++isByteVector :: LispVal -> ThrowsError LispVal+isByteVector (ByteVector _) = return $ Bool True+isByteVector _ = return $ Bool False  isNull :: [LispVal] -> ThrowsError LispVal isNull ([List []]) = return $ Bool True

@@ -14,21 +14,26 @@ -}  module Language.Scheme.Types-    ( Env (..)+    ( +    -- * Environments+      Env (..)     , nullEnv +    -- * Error Handling     , LispError (..)     , ThrowsError +    , IOThrowsError      , trapError     , extractValue -    , IOThrowsError      , liftThrows      , runIOThrowsREPL      , runIOThrows +    -- * Types and related functions     , LispVal (           Atom         , List         , DottedList         , Vector+        , ByteVector         , HashTable         , Number         , Float@@ -92,11 +97,13 @@ import Control.Monad.Error import Data.Complex import Data.Array+import qualified Data.ByteString as BS import Data.Dynamic import Data.IORef import qualified Data.Map -- import Data.Maybe import Data.Ratio+import Data.Word import System.IO import Text.ParserCombinators.Parsec hiding (spaces) @@ -121,10 +128,10 @@   | TypeMismatch String LispVal -- ^Type error   | Parser ParseError -- ^Parsing error   | BadSpecialForm String LispVal -- ^Invalid special (built-in) form-  | NotFunction String String-  | UnboundVar String String+--  | NotFunction String String+  | UnboundVar String String -- ^ A referenced variable has not been declared   | DivideByZero -- ^Divide by Zero error-  | NotImplemented String+  | NotImplemented String -- ^ Feature is not implemented   | InternalError String {- ^An internal error within husk; in theory user (Scheme) code                          should never allow one of these errors to be triggered. -}   | Default String -- ^Default error@@ -137,7 +144,7 @@                                   ++ ", found " ++ show found showError (Parser parseErr) = "Parse error at " ++ ": " ++ show parseErr showError (BadSpecialForm message form) = message ++ ": " ++ show form-showError (NotFunction message func) = message ++ ": " ++ show func+-- showError (NotFunction message func) = message ++ ": " ++ show func showError (UnboundVar message varname) = message ++ ": " ++ varname showError (DivideByZero) = "Division by zero" showError (NotImplemented message) = "Not implemented: " ++ message@@ -149,19 +156,24 @@   noMsg = Default "An error has occurred"   strMsg = Default +-- |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; "+extractValue (Left _) = error "Unexpected error in extractValue" +-- |Container used to provide error handling in the IO monad type IOThrowsError = ErrorT LispError IO +-- |Lift a ThrowsError into the IO monad liftThrows :: ThrowsError a -> IOThrowsError a liftThrows (Left err) = throwError err liftThrows (Right val) = return val@@ -189,6 +201,8 @@  -- ^Pair  | Vector (Array Int LispVal)  -- ^Vector+ | ByteVector BS.ByteString+ -- ^ByteVector from R7RS  | HashTable (Data.Map.Map LispVal LispVal)  {- ^Hash table.  Technically this could be a derived data type instead of being built-in to the@@ -197,9 +211,11 @@  --  -- Map is technically the wrong structure to use for a hash table since it is based on a binary tree and hence operations tend to be O(log n) instead of O(1). However, according to <http://www.opensubscriber.com/message/haskell-cafe@haskell.org/10779624.html> Map has good performance characteristics compared to the alternatives. So it stays for the moment...  --- | Number Integer {- FUTURE: rename this to "Integer" (or "WholeNumber" or something else more meaningful)+ | Number Integer -- ^Integer number+ {- FUTURE: rename this to "Integer" (or "WholeNumber" or something else more meaningful)  Integer -}- | Float Double {- FUTURE: rename this "Real" instead of "Float"...+ | Float Double -- ^Double-precision floating point number+ {- FUTURE: rename this "Real" instead of "Float"...  Floating point -}  | Complex (Complex Double)  -- ^Complex number@@ -247,7 +263,7 @@  | Syntax { synClosure :: Maybe Env       -- ^ Code env in effect at definition time, if applicable           , synRenameClosure :: Maybe Env -- ^ Renames (from macro hygiene) in effect at def time;                                           --   only applicable if this macro defined inside another macro.-          , synDefinedInMacro :: Bool+          , synDefinedInMacro :: Bool     -- ^ Set if macro is defined within another macro           , synIdentifiers :: [LispVal]   -- ^ Literal identifiers from syntax-rules            , synRules :: [LispVal]         -- ^ Rules from syntax-rules    } -- ^ Type to hold a syntax object that is created by a macro definition.@@ -260,7 +276,9 @@  | SyntaxExplicitRenaming LispVal    -- ^ Syntax for an explicit-renaming macro  | LispEnv Env+   -- ^ Wrapper for a scheme environment  | EOF+   -- ^ End of file indicator  | Nil String  -- ^Internal use only; do not use this type directly. @@ -297,19 +315,44 @@  instance Show DynamicWinders where show = showDWVal --- Make an "empty" continuation that does not contain any code+-- |Make an "empty" continuation that does not contain any code makeNullContinuation :: Env -> LispVal makeNullContinuation env = Continuation env Nothing Nothing Nothing Nothing --- Make a continuation that takes a higher-order function (written in Haskell)-makeCPS :: Env -> LispVal -> (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal) -> LispVal+-- |Make a continuation that takes a higher-order function (written in Haskell)+makeCPS :: Env +        -- ^ Environment+        -> LispVal +        -- ^ Current continuation+        -> (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal) +        -- ^ Haskell function+        -> LispVal+        -- ^ The Haskell function packaged as a LispVal makeCPS env cont@(Continuation _ _ _ _ dynWind) cps = Continuation env (Just (HaskellBody cps Nothing)) (Just cont) Nothing dynWind makeCPS env cont cps = Continuation env (Just (HaskellBody cps Nothing)) (Just cont) Nothing Nothing -- This overload just here for completeness; it should never be used --- Make a continuation that stores a higher-order function and arguments to that function-makeCPSWArgs :: Env -> LispVal -> (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal) -> [LispVal] -> LispVal-makeCPSWArgs env cont@(Continuation _ _ _ _ dynWind) cps args = Continuation env (Just (HaskellBody cps (Just args))) (Just cont) Nothing dynWind-makeCPSWArgs env cont cps args = Continuation env (Just (HaskellBody cps (Just args))) (Just cont) Nothing Nothing -- This overload just here for completeness; it should never be used+-- |Make a continuation that stores a higher-order function and arguments to that function+makeCPSWArgs :: Env+        -- ^ Environment+        -> LispVal +        -- ^ Current continuation+        -> (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal) +        -- ^ Haskell function+        -> [LispVal]+        -- ^ Arguments to the function+        -> LispVal+        -- ^ The Haskell function packaged as a LispVal+makeCPSWArgs env cont@(Continuation _ _ _ _ dynWind) cps args = +    Continuation +        env +        (Just (HaskellBody cps (Just args))) +        (Just cont) Nothing dynWind+makeCPSWArgs env cont cps args = +    -- This overload just here for completeness; it should never be used+    Continuation +        env +        (Just (HaskellBody cps (Just args))) +        (Just cont) Nothing Nothing  instance Ord LispVal where   compare (Bool a) (Bool b) = compare a b@@ -328,7 +371,10 @@   compare a b = compare (show a) (show b) -- Hack (??): sort alphabetically when types differ or have no handlers  -- |Compare two 'LispVal' instances-eqv :: [LispVal] -> ThrowsError LispVal+eqv :: [LispVal] +    -- ^ A list containing two values to compare+    -> ThrowsError LispVal+    -- ^ Result wrapped as a Bool eqv [(Bool arg1), (Bool arg2)] = return $ Bool $ arg1 == arg2 eqv [(Number arg1), (Number arg2)] = return $ Bool $ arg1 == arg2 eqv [(Complex arg1), (Complex arg2)] = return $ Bool $ arg1 == arg2@@ -339,6 +385,7 @@ eqv [(Atom arg1), (Atom arg2)] = return $ Bool $ arg1 == arg2 eqv [(DottedList xs x), (DottedList ys y)] = eqv [List $ xs ++ [x], List $ ys ++ [y]] eqv [(Vector arg1), (Vector arg2)] = eqv [List $ (elems arg1), List $ (elems arg2)]+eqv [(ByteVector a), (ByteVector b)] = return $ Bool $ a == b eqv [(HashTable arg1), (HashTable arg2)] =   eqv [List $ (map (\ (x, y) -> List [x, y]) $ Data.Map.toAscList arg1),        List $ (map (\ (x, y) -> List [x, y]) $ Data.Map.toAscList arg2)]@@ -379,6 +426,7 @@                                _ -> False -- OK? eqvList _ _ = throwError $ Default "Unexpected error in eqvList" +-- |A more convenient way to call /eqv/ eqVal :: LispVal -> LispVal -> Bool eqVal a b = do   let result = eqv [a, b]@@ -405,6 +453,7 @@ showVal (Bool True) = "#t" showVal (Bool False) = "#f" showVal (Vector contents) = "#(" ++ (unwordsList $ Data.Array.elems contents) ++ ")"+showVal (ByteVector contents) = "#u8(" ++ unwords (map show (BS.unpack contents)) ++ ")" showVal (HashTable _) = "<hash-table>" showVal (List contents) = "(" ++ unwordsList contents ++ ")" showVal (DottedList h t) = "(" ++ unwordsList h ++ " . " ++ showVal t ++ ")"

@@ -20,6 +20,7 @@       printEnv     , copyEnv     , extendEnv+    , topmostEnv     , findNamespacedEnv     , macroNamespace     , varNamespace @@ -49,11 +50,11 @@ import qualified Data.Map -- import Debug.Trace --- Internal namespace for macros+-- |Internal namespace for macros macroNamespace :: [Char] macroNamespace = "m" --- Internal namespace for variables+-- |Internal namespace for variables varNamespace :: [Char] varNamespace = "v" @@ -100,7 +101,7 @@  where    showVar (name, val) = do     v <- liftIO $ readIORef val-    return $ name ++ ": " ++ show v+    return $ "[" ++ name ++ "]" ++ ": " ++ show v  -- |Create a deep copy of an environment copyEnv :: Env      -- ^ Source environment@@ -118,6 +119,13 @@          ref <- newIORef x          return (name, ref) +-- -- |Perform a deep copy of an environment's contents to a new environment+-- importEnv +--   :: Env -- ^ Source environment+--   -> Env -- ^ Destination environment+--   -> IO () = do+-- -- TODO: need to do this recursively?+ -- |Extend given environment by binding a series of values to a new environment. extendEnv :: Env -- ^ Environment            -> [((String, String), LispVal)] -- ^ Extensions to the environment@@ -130,6 +138,13 @@  where addBinding ((namespace, name), val) = do ref <- newIORef val                                                 return (getVarName namespace name, ref) +-- |Find the top-most environment+topmostEnv :: Env -> IO Env+topmostEnv envRef = do+    case parentEnv envRef of+        Just p -> topmostEnv p+        Nothing -> return envRef+ -- |Recursively search environments to find one that contains the given variable. findNamespacedEnv      :: Env      -- ^Environment to begin the search; @@ -219,8 +234,24 @@ setNamespacedVar envRef                  namespace                  var value = do -  _ <- updatePointers envRef namespace var -  _setNamespacedVar envRef namespace var value+  -- Issue #98 - Need to detect circular references+  --+  -- TODO:+  -- Note this implementation is rather simplistic since+  -- it does not take environments into account. The same+  -- variable name could refer to 2 different variables in+  -- different environments.+  case value of+    Pointer p env -> do+      if p == var +          then return value+          else next+    _ -> next++  where +    next = do+      _ <- updatePointers envRef namespace var +      _setNamespacedVar envRef namespace var value  -- |An internal function that does the actual setting of a  --  variable, without all the extra code that keeps pointers

@@ -1,5 +1,5 @@ Name:                husk-scheme-Version:             3.6.2+Version:             3.6.3 Synopsis:            R5RS Scheme interpreter, compiler, and library. Description:            <<https://github.com/justinethier/husk-scheme/raw/master/docs/husk-scheme.png>>@@ -56,7 +56,7 @@     default: True  Library-  Build-Depends:   base >= 2.0 && < 5, array, containers, haskeline, transformers, mtl, parsec, directory+  Build-Depends:   base >= 2.0 && < 5, array, containers, haskeline, transformers, mtl, parsec, directory, bytestring, utf8-string   Extensions:      ExistentialQuantification   Hs-Source-Dirs:  hs-src   Exposed-Modules: Language.Scheme.Core

@@ -323,6 +323,18 @@      (set! _vec            (make-vector (vector-length _vec) _fill))))) +; Bytevector Section++; TODO: add appropriate overloads, also note this is not the+; fastest implementation+(define (bytevector-copy! to at from start end)+  (do ((i 0 (+ i 1)))+      ((= i (- end start)))+    (bytevector-u8-set! +        to+        (+ at i) +        (bytevector-u8-ref from (+ start i)))))+ ; Continuation Section (define (values . things)     (call-with-current-continuation