haskeem (empty) → 0.6.10
raw patch · 21 files changed
+7739/−0 lines, 21 filesdep +basedep +containersdep +directorysetup-changed
Dependencies added: base, containers, directory, haskeline, haskell98, mtl, network, old-time, parsec, random, unix
Files
- Environment.hs +74/−0
- Evaluator.hs +756/−0
- LICENSE +339/−0
- Library.hs +1483/−0
- LispData.hs +189/−0
- Parser.hs +414/−0
- README +34/−0
- Setup.hs +3/−0
- WriteNumber.hs +253/−0
- fibo.scm +63/−0
- gendoc.scm +67/−0
- guard.scm +22/−0
- hamming.scm +32/−0
- haskeem.cabal +26/−0
- haskeem.doc +346/−0
- haskeem.hs +135/−0
- haskeem_readline.hs +159/−0
- powerseries.scm +226/−0
- primes.scm +41/−0
- selftest.scm +2636/−0
- stdlib.scm +441/−0
+ Environment.hs view
@@ -0,0 +1,74 @@+{- Copyright 2008 Uwe Hollerbach <uh@alumni.caltech.edu>+Portions of this were derived from Jonathan Tang's haskell+tutorial "Write yourself a scheme in 48 hours" and are thus+Copyright Jonathan Tang+(but I can't easily tell anymore who originally wrote what)++This file is part of haskeem.+haskeem is free software; you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation; either version 2 of the License, or+(at your option) any later version.++haskeem is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+GNU General Public License for more details.++You should have received a copy of the GNU General Public License+along with haskeem; if not, write to the Free Software+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA++$Id: environment.hs,v 1.10 2009-05-31 01:41:07 uwe Exp $ -}++module Environment (isBound, getVar, setVar,+ defineVar, bindVars, dumpEnv) where+import Prelude+import IO+import Control.Monad.Error as CME+import Data.IORef++import LispData++liftRead = liftIO . readIORef++isBound :: Env -> String -> IO Bool+isBound envRef var =+ do env <- liftIO (readIORef envRef)+ return (maybe False (const True) (lookup var env))++getVar :: Env -> String -> IOThrowsError LispVal+getVar envRef var =+ do env <- liftRead envRef+ maybe (throwError (UnboundVar "Getting an unbound variable" var))+ liftRead (lookup var env)++setVar :: Env -> String -> LispVal -> IOThrowsError LispVal+setVar envRef var value =+ do env <- liftRead envRef+ maybe (throwError (UnboundVar "Setting an unbound variable" var))+ (liftIO . (flip writeIORef value))+ (lookup var env)+ return value++defineVar :: Env -> String -> LispVal -> IOThrowsError LispVal+defineVar envRef var value =+ liftIO (do valueRef <- newIORef value+ env <- readIORef envRef+ writeIORef envRef ((var, valueRef) : env)+ return value)++bindVars :: Env -> [(String, LispVal)] -> IO Env+bindVars envRef bindings =+ readIORef envRef >>= extendEnv >>= newIORef+ where extendEnv env = liftM (++ env) (mapM addBinding bindings)+ addBinding (var, value) = do ref <- newIORef value+ return (var, ref)++dumpEnv :: Env -> Handle -> IOThrowsError LispVal+dumpEnv envRef port = liftRead envRef >>= doDump+ where doDump [] = return (Bool True)+ doDump ((key, vref):vars) =+ do val <- liftRead vref+ liftIO (hPutStrLn port (key ++ " -> " ++ (show val)))+ doDump vars
+ Evaluator.hs view
@@ -0,0 +1,756 @@+{- Copyright 2008 Uwe Hollerbach <uh@alumni.caltech.edu>+Portions of this were derived from Jonathan Tang's haskell+tutorial "Write yourself a scheme in 48 hours" and are thus+Copyright Jonathan Tang+(but I can't easily tell anymore who originally wrote what)++This file is part of haskeem.+haskeem is free software; you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation; either version 2 of the License, or+(at your option) any later version.++haskeem is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+GNU General Public License for more details.++You should have received a copy of the GNU General Public License+along with haskeem; if not, write to the Free Software+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA++$Id: evaluator.hs,v 1.26 2009-05-31 01:41:07 uwe Exp $ -}++module Evaluator (evalLisp) where+import Prelude+import IO+import Control.Exception as CE()+import Control.Monad.Error as CME+import Data.IORef()+import qualified Data.IntMap as DIM++import LispData+import Environment+import Library++errNumArgs name want got = throwError (NumArgs name want got)+errTypeMismatch name want got = throwError (TypeMismatch name want got)+errBadForm name args =+ throwError (BadSpecial ("bad " ++ name ++ " form") (List args))++-- Debugging output: either inside haskeem while tracing something,+-- or inside haskeem while debugging haskeem++remark str = liftIO (hPutStrLn stderr str)++progError = error "internal error!"++lastOrNil = liftM lON+ where lON [] = List []+ lON l = last l++isTrue :: LispVal -> Bool+isTrue (Bool False) = False+isTrue _ = True++-- Check that a variable is unique in a list,+-- for the various forms of "let" and for "do"++uniqCheck :: String -> [LispVal] -> Bool+uniqCheck _ [] = True+uniqCheck name ((List ((Symbol var):_)):rest) =+ if name == var then False else uniqCheck name rest+uniqCheck _ _ = progError++-- Check the variable bindings in the various forms of "let".+-- The "uniq" boolean argument specifies whether or not multiple+-- instances of the same name are allowed.++letCheck :: Bool -> [LispVal] -> Bool+letCheck _ [] = True+letCheck uniq ((List [Symbol var, _]):rest) =+ letCheck uniq rest && ((not uniq) || (uniq && uniqCheck var rest))+letCheck _ _ = False++-- Ditto for "do", except that we have two kinds of syntax:+-- (var-name init-expr step-expr) and (var-name init-expr)++doCheck :: [LispVal] -> Bool+doCheck [] = True+doCheck ((List [Symbol var, _]):rest) =+ doCheck rest && uniqCheck var rest+doCheck ((List [Symbol var, _, _]):rest) =+ doCheck rest && uniqCheck var rest+doCheck _ = False++-- Ditto for "define" and "lambda" params lists and dotted-lists++paramsCheck :: [LispVal] -> Bool+paramsCheck [] = True+paramsCheck ((Symbol var):rest) =+ paramsCheck rest && uC var rest+ where uC _ [] = True+ uC name ((Symbol var2):rest) =+ if name == var2 then False else uC name rest+ uC _ _ = progError+paramsCheck _ = False++-- This is the apply function, the generic+-- omnipotent thing that does all the work++doApply :: Bool -> String -> [String] -> (Maybe String) -> [LispVal]+ -> Env -> Integer -> [LispVal] -> IOThrowsError LispVal+doApply trace name params varargs body closure ql args =+ if num params /= num args && varargs == Nothing+ then errNumArgs (show body) (num params) args+ else prtTrace >>+ (liftIO (bindVars closure (zip params args))) >>=+ bindVarArgs varargs >>= evalBody+ where remainingArgs = drop (length params) args+ num = toInteger . length+ evalBody env = lastOrNil (mapM (evalLisp env ql) body)+ bindVarArgs arg env =+ case arg of+ Just argName ->+ liftIO (bindVars env [(argName, List (remainingArgs))])+ Nothing -> return env+ prtTrace =+ if trace+ then remark ("trace: " ++ name ++ " <- " ++ (show (List args))) >>+ return True+ else return False++apply :: Integer -> LispVal -> [LispVal] -> IOThrowsError LispVal+apply _ (Prim func) args = liftThrows (func args)+apply _ (IOPrim func) args = func args+apply ql (Func params varargs body closure) args =+ doApply False "" params varargs body closure ql args+apply ql (TraceFunc name params varargs body closure) args =+ doApply True name params varargs body closure ql args+apply _ func _ = throwError (NotFunction "apply got non-function" func)++makeFunc varargs env params body =+ return (Func (map show params) varargs body env)+makeNormalFunc = makeFunc Nothing+makeVarargs = makeFunc . Just . show++isSpecialForm :: LispVal -> Bool+isSpecialForm (Symbol "and") = True+isSpecialForm (Symbol "apply") = True+isSpecialForm (Symbol "begin") = True+isSpecialForm (Symbol "case") = True+isSpecialForm (Symbol "cond") = True+isSpecialForm (Symbol "define") = True+isSpecialForm (Symbol "delay") = True+isSpecialForm (Symbol "do") = True+isSpecialForm (Symbol "eval") = True+isSpecialForm (Symbol "force") = True+isSpecialForm (Symbol "guard") = True+isSpecialForm (Symbol "if") = True+isSpecialForm (Symbol "lambda") = True+isSpecialForm (Symbol "let") = True+isSpecialForm (Symbol "let*") = True+isSpecialForm (Symbol "letrec") = True+isSpecialForm (Symbol "letrec*") = True+isSpecialForm (Symbol "load") = True+isSpecialForm (Symbol "new-symbol") = True+isSpecialForm (Symbol "or") = True+isSpecialForm (Symbol "quasiquote") = True+isSpecialForm (Symbol "quote") = True+isSpecialForm (Symbol "set!") = True+isSpecialForm (Symbol "unless") = True+isSpecialForm (Symbol "unquote") = True+isSpecialForm (Symbol "unquote-splicing") = True+isSpecialForm (Symbol "vector-fill!") = True+isSpecialForm (Symbol "vector-set!") = True+isSpecialForm (Symbol "when") = True++isSpecialForm (Symbol "trace") = True+isSpecialForm (Symbol "dump-bindings") = True+isSpecialForm _ = False++-- This is an internal symbol which temporarily replaces "unquote" and+-- "unquote-splicing" after these have evaluated the expression(s): evalQQ+-- looks for this marker and lifts the remainder of the list up by one+-- level, turning (1 2 (' unq' 7)) into (1 2 7): this makes `(1 2 ,(+ 3 4))+-- come out right (otherwise it turns into (1 2 (7)). Notice that this+-- begins with a space: that's necessary to guarantee there will be no+-- collisions with user-generated symbols.++unq :: String+unq = " unq"++-- This is the list-context unquote-lifting function:++liftLUnq :: [LispVal] -> [LispVal]+liftLUnq lst = lunq [] lst+ where lunq acc [] = acc+ lunq acc (l@(List ((Symbol sym):vals)):ls) =+ if sym == unq+ then lunq (acc ++ vals) ls+ else lunq (acc ++ [l]) ls+ lunq acc (l:ls) = lunq (acc ++ [l]) ls++-- and the scalar-context equivalent++liftSUnq :: LispVal -> IOThrowsError LispVal+liftSUnq l@(List ((Symbol sym):vals)) =+ if sym == unq+ then if (length vals) == 1+ then return (head vals)+ else throwError (Default "list unquote form in scalar context")+ else return l+liftSUnq v = return v++-- evalQQ is more or less a specialized version of evalLisp: It just walks+-- the tree, returning everything unevaluated, except if it finds an unquote+-- or an unquote-splicing at the right quote level; these it evaluates via+-- evalLisp and patches into the tree++evalQQ :: Env -> Integer -> LispVal -> IOThrowsError LispVal++-- "quasiquote", "unquote", and "unquote-splicing" might get evaluated,+-- depending on quote level++evalQQ env ql (List [Symbol "quasiquote", arg]) =+ do val <- evalQQ env (ql + 1) arg >>= liftSUnq+ return (List [Symbol "quasiquote", val])++evalQQ env ql (List (Symbol "unquote" : args)) =+ if ql == 1+ then do vals <- mapM (evalLisp env 0) args+ return (List ((Symbol unq):vals))+ else do vals <- mapM (evalQQ env (ql - 1)) args+ return (List ((Symbol "unquote") : (liftLUnq vals)))++evalQQ env ql (List (Symbol "unquote-splicing" : args)) =+ if ql == 1+ then do vals <- mapM (evalLisp env 0) args+ if isList vals+ then return (List ((Symbol unq):(peel vals)))+ else throwError (Default ("bad unquote-splicing form: " +++ (show args)))+ else do vals <- mapM (evalQQ env (ql - 1)) args+ return (List ((Symbol "unquote-splicing") : (liftLUnq vals)))+ where isList [] = True+ isList ((List _):ls) = isList ls+ isList _ = False+ peel [] = []+ peel ((List l):ls) = l ++ (peel ls)++-- lists, dotted-lists, and vectors get traversed++evalQQ env ql (List con) =+ mapM (evalQQ env ql) con >>= return . List . liftLUnq++evalQQ env ql (DottedList con cab) =+ do vals <- mapM (evalQQ env ql) con+ vcab <- evalQQ env ql cab >>= liftSUnq+ let head = liftLUnq vals+ if isl vcab+ then return (List (head ++ (unpl vcab)))+ else if isdl vcab+ then return (DottedList (head ++ (unpdlh vcab)) (unpdlt vcab))+ else return (DottedList head vcab)+ where isl (List _) = True+ isl _ = False+ unpl (List l) = l+ isdl (DottedList _ _) = True+ isdl _ = False+ unpdlh (DottedList h _) = h+ unpdlt (DottedList _ t) = t++evalQQ env ql (Vector _ con) =+ do vals <- mapM (evalQQ env ql) (remkey (DIM.toAscList con))+ let new = DIM.fromAscList (addkey 0 (liftLUnq vals))+ return (Vector (toInteger (DIM.size new)) new)+ where remkey [] = []+ remkey ((_, v):vs) = v:(remkey vs)+ addkey _ [] = []+ addkey n (v:vs) = (n, v):(addkey (n+1) vs)++-- anything else gets returned unchanged++evalQQ _ _ val@_ = return val++-- This is the main evaluator++evalLisp :: Env -> Integer -> LispVal -> IOThrowsError LispVal++-- various simple things which evaluate to themselves++evalLisp _ _ val@(String _) = return val+evalLisp _ _ val@(IntNumber _) = return val+evalLisp _ _ val@(RatNumber _) = return val+evalLisp _ _ val@(FltNumber _) = return val+evalLisp _ _ val@(Bool _) = return val+evalLisp _ _ val@(Char _) = return val+evalLisp _ _ (List []) = return (List [])+evalLisp env _ (Symbol id) = getVar env id++-- Special forms must go here, before the generic (function : args) stuff++-- TODO: implement set-car! and set-cdr! (but how?)++-- (apply) doesn't strictly need to be a special form, but it's far more+-- convenient to have it here; otherwise, we have to do all sorts of+-- twisting to make it all work.++evalLisp env ql (List (Symbol "apply" : function : args)) =+ do func <- evalLisp env ql function+ argVals <- mapM (evalLisp env ql) args+ appp ql (func:argVals)+ where appp ql [func, List args] = apply ql func args+ appp ql (func : args) = apply ql func args++-- TODO: this is not a special form according to R6RS; the only reason+-- I put it here is because evalLisp wants an environment, and that's+-- provided here more conveniently than in library.hs. In order to+-- make stuff like "(map eval (list 'foo 'bar 'baz))" work in addition+-- to "(eval 'foo)", there is a hack "(define (eval x) (eval x))" in+-- stdlib.scm. Hmmm... reading R6RS more closely, it seems that they+-- do not make eval work in the current environment; it's some+-- sanitized top-level environment. That would make it possible to+-- move this into the libraries... I'd just have to provide access to+-- the (or a) top-level environment.++evalLisp env ql (List (Symbol "eval" : args)) =+ do argVals <- mapM (evalLisp env ql) args+ lastOrNil (mapM (evalLisp env ql) argVals)++-- TODO: This is also not a special form according to R6RS; I think I+-- could also make it a regular function, but it has the same issues+-- as "eval". It would most likely be safe to just provide access to+-- the top-level environment here; it's really unlikely that anyone+-- wants to (or should be able to) call (load) from within some+-- function and modify the environment seen within that function.++evalLisp env ql (List [Symbol "load", String filename]) =+ loadFile filename >>= lastOrNil . mapM (evalLisp env ql)++evalLisp env ql (List (Symbol "begin" : args)) =+ lastOrNil (mapM (evalLisp env ql) args)++evalLisp _ _ (List [Symbol "quote", val]) = return val++evalLisp env ql (List [Symbol "quasiquote", val]) =+ evalQQ env (ql + 1) val >>= liftSUnq++evalLisp _ _ (List (Symbol "unquote" : args)) =+ throwError (Default ("naked unquote form: " ++ (show args)))++evalLisp _ _ (List (Symbol "unquote-splicing" : args)) =+ throwError (Default ("naked unquote-splicing form: " ++ (show args)))++evalLisp env ql (List [Symbol "set!", Symbol var, val]) =+ evalLisp env ql val >>= setVar env var++evalLisp env ql (List [Symbol "vector-set!", Symbol var, indx, obj]) =+ do vec <- evalLisp env ql (Symbol var)+ if isVec vec+ then do lk <- evalLisp env ql indx+ let l = getL vec+ k = getI lk+ if ((isI lk) && k >= 0 && k < l)+ then do val <- evalLisp env ql obj+ setVar env var (Vector l+ (DIM.insert (fromInteger k) val (getV vec)))+ else throwError (VectorBounds l lk)+ else throwError (Default ("bad vector-set! form: " +++ (show var) ++ " is not a vector"))+ where isVec (Vector _ _) = True+ isVec _ = False+ isI (IntNumber _) = True+ isI _ = False+ getI (IntNumber n) = n+ getL (Vector l _) = l+ getV (Vector _ v) = v++evalLisp env ql (List [Symbol "vector-fill!", Symbol var, obj]) =+ do vec <- evalLisp env ql (Symbol var)+ if isVec vec+ then do val <- evalLisp env ql obj+ let n = getL vec+ setVar env var (Vector n (DIM.fromAscList+ (addkey val (fromInteger n))))+ else throwError (Default ("bad vector-fill! form: " +++ (show var) ++ " is not a vector"))+ where isVec (Vector _ _) = True+ isVec _ = False+ getL (Vector l _) = l+ addkey _ 0 = []+ addkey v n = ((n-1), v):(addkey v (n-1))++evalLisp env ql (List [Symbol "vector-resize!", Symbol var, obj]) =+ do vec <- evalLisp env ql (Symbol var)+ if isVec vec+ then do lk <- evalLisp env ql obj+ let l = getL vec+ k = getI lk+ if (isI lk) && (k > 0)+ then do let new = if k < l+ then rem (getV vec) l k+ else add (getV vec) k l+ setVar env var (Vector k new)+ else throwError (Default ("bad vector-resize! size: " +++ (show k)))+ else throwError (Default ("bad vector-resize! form: " +++ (show var) ++ " is not a vector"))+ where isVec (Vector _ _) = True+ isVec _ = False+ getL (Vector l _) = l+ getV (Vector _ v) = v+ isI (IntNumber _) = True+ isI _ = False+ getI (IntNumber n) = n+ rem vec h l =+ if h == l+ then vec+ else rem (DIM.delete (fromInteger l) vec) h (l + 1)+ add vec h l =+ if h == l+ then vec+ else add (DIM.insert (fromInteger l) (Bool False) vec) h (l + 1)++evalLisp env ql (List [Symbol "define", Symbol var, val]) =+ do defineVar env var (Bool False)+ evalLisp env ql val >>= setVar env var+evalLisp env _ (List [Symbol "define", Symbol var]) =+ defineVar env var (Bool False)+evalLisp env _ (List (Symbol "define" : List (Symbol var : params) : body)) =+ if paramsCheck params+ then do defineVar env var (Bool False)+ makeNormalFunc env params body >>= setVar env var+ else errBadForm "define" params+evalLisp env _ (List (Symbol "define" :+ DottedList (Symbol var : params) varargs : body)) =+ if paramsCheck (params ++ [varargs])+ then do defineVar env var (Bool False)+ makeVarargs varargs env params body >>= setVar env var+ else errBadForm "define" [DottedList params varargs]++evalLisp env _ (List (Symbol "lambda" : List params : body)) =+ if paramsCheck params+ then makeNormalFunc env params body+ else errBadForm "lambda" params+evalLisp env _ (List (Symbol "lambda" : DottedList params varargs : body)) =+ if paramsCheck (params ++ [varargs])+ then makeVarargs varargs env params body+ else errBadForm "lambda" [DottedList params varargs]+evalLisp env _ (List (Symbol "lambda" : varargs@(Symbol _) : body)) =+ makeVarargs varargs env [] body++evalLisp env ql (List [Symbol "if", pred, tcase, fcase]) =+ do result <- evalLisp env ql pred+ case result of+ Bool False -> evalLisp env ql fcase+ _ -> evalLisp env ql tcase+evalLisp env ql (List [Symbol "if", pred, tcase]) =+ do result <- evalLisp env ql pred+ case result of+ Bool False -> return (Bool False)+ _ -> evalLisp env ql tcase++evalLisp env ql (List (Symbol "when" : pred : docase)) =+ do result <- evalLisp env ql pred+ case result of+ Bool False -> return (Bool False)+ _ -> lastOrNil (mapM (evalLisp env ql) docase)++evalLisp env ql (List (Symbol "unless" : pred : docase)) =+ do result <- evalLisp env ql pred+ case result of+ Bool False -> lastOrNil (mapM (evalLisp env ql) docase)+ _ -> return (Bool False)++evalLisp env ql (List (Symbol "and" : args)) = eva env args (Bool True)+ where eva _ [] ret = return ret+ eva env (t:ts) _ =+ do result <- evalLisp env ql t+ case result of+ Bool False -> return (Bool False)+ _ -> eva env ts result++evalLisp env ql (List (Symbol "or" : args)) = evo env args (Bool False)+ where evo _ [] ret = return ret+ evo env (t:ts) _ =+ do result <- evalLisp env ql t+ case result of+ Bool False -> evo env ts result+ _ -> return result++evalLisp _ _ (List [Symbol "cond"]) = return (Bool False)+evalLisp env ql (List (Symbol "cond" : args)) =+ if foldl1 (&&) (map isList args) == False+ then errTypeMismatch "cond" "cond-clauses" (String (show args))+ else evc env args+ where isList (List _) = True+ isList _ = False+ evc _ [] = return (Bool False)+ evc env (cl:cls) = do (tst,val) <- evc_clause env cl+ if tst then return val else evc env cls+ evc_clause env (List (Symbol "else" : args)) =+ do ret <- lastOrNil (mapM (evalLisp env ql) args)+ return (True, ret)+ evc_clause env (List (pred : args)) =+ do tst <- evalLisp env ql pred+ case tst of+ Bool False -> return (False, (Bool False))+ _ -> do ret <- if isArrow args+ then evcArrow env args tst+ else lastOrNil+ (mapM (evalLisp env ql) args)+ return (True, ret)+ evc_clause _ _ = return (False, (Bool False))+ isArrow [Symbol "=>", _] = True+ isArrow _ = False+ evcArrow env [Symbol "=>", proc] val =+ evalLisp env ql proc >>= (flip (apply ql)) [val]++evalLisp env ql (List (Symbol "let" : List params : body)) =+ if letCheck True params+ then do func <- makeNormalFunc env (map exn params) body+ argVals <- mapM (evalLisp env ql) (map exv params)+ apply ql func argVals+ else errBadForm "let" params+ where exn (List [Symbol var, _]) = Symbol var+ exv (List [Symbol _, val]) = val++evalLisp env ql (List (Symbol "let" : Symbol lname : List params : body)) =+ if letCheck True params+ then do envn <- liftIO (bindVars env [(lname, Bool False)])+ func <- makeNormalFunc envn (map exn params) body+ setVar envn lname func+ argVals <- mapM (evalLisp env ql) (map exv params)+ apply ql func argVals+ else errBadForm "named-let" params+ where exn (List [Symbol var, _]) = Symbol var+ exv (List [Symbol _, val]) = val++evalLisp env ql (List (Symbol "let*" : List params : body)) =+ if letCheck False params+ then dols params body env+ else errBadForm "let*" params+ where dols [] body env = lastOrNil (mapM (evalLisp env ql) body)+ dols (p:ps) body env =+ do val <- evalLisp env ql (exv p)+ (liftIO (bindVars env [(exn p, val)])) >>= (dols ps body)+ exn (List [Symbol var, _]) = var+ exv (List [Symbol _, val]) = val++evalLisp env ql (List (Symbol "letrec" : List params : body)) =+ if letCheck True params+ then dolr params body env+ else errBadForm "letrec" params+ where dolr params body env =+ do let varn = map exn params+ envn <- liftIO (bindVars env varn)+ varv <- mapM (evalLisp envn ql) (map exv params)+ mapM (doSet envn) (repl varn varv) >>+ lastOrNil (mapM (evalLisp envn ql) body)+ exn (List [Symbol var, _]) = (var, Bool False)+ exv (List [Symbol _, val]) = val+ repl [] [] = []+ repl ((n, Bool False):ns) (v:vs) = (n, v):(repl ns vs)+ doSet env (n,v) = setVar env n v++evalLisp env ql (List (Symbol "letrec*" : List params : body)) =+ if letCheck False params+ then dolr params body env+ else errBadForm "letrec*" params+ where dolr params body env =+ do let varn = map exn params+ envn <- liftIO (bindVars env varn)+ mapM (evSet envn) params >>+ lastOrNil (mapM (evalLisp envn ql) body)+ exn (List [Symbol var, _]) = (var, Bool False)+ evSet env (List [Symbol var, val]) =+ evalLisp env ql val >>= setVar env var++evalLisp _ _ (List [Symbol "case"]) = return (Bool False)+evalLisp env ql (List (Symbol "case" : key : args)) =+ if (isNull args) || (foldl1 (&&) (map isList args) == False)+ then errTypeMismatch "case" "case-clauses" (String (show args))+ else evalLisp env ql key >>= evc env args+ where isNull [] = True+ isNull _ = False+ isList (List (List _ : _)) = True+ isList (List (Symbol "else" : _)) = True+ isList _ = False+ evc _ [] _ = return (Bool False)+ evc env (cl:cls) key = do (tst,val) <- evc_clause env cl key+ if tst then return val else evc env cls key+ evc_clause env (List (Symbol "else" : args)) _ =+ do ret <- lastOrNil (mapM (evalLisp env ql) args)+ return (True, ret)+ evc_clause env (List (List vals : args)) key =+ if valMatch key vals+ then do ret <- lastOrNil (mapM (evalLisp env ql) args)+ return (True, ret)+ else return (False, (Bool False))+ evc_clause _ _ _ = return (False, (Bool False))+ valMatch key (v:vs) = if Library.eqv [key, v]+ then True+ else (valMatch key vs)+ valMatch _ [] = False++evalLisp env ql (List (Symbol "guard" : List (Symbol var : clauses) : body)) =+ if foldl (&&) True (map isList clauses) == False+ then errTypeMismatch "guard" "error-clauses" (String (show clauses))+ else catchError (lastOrNil (mapM (evalLisp env ql) body))+ (\err -> do let errval = unpackErr err+ liftIO (bindVars env [(var, errval)]) >>=+ evc err clauses)+ where isList (List _) = True+ isList _ = False+ unpackErr (UserException val) = val+ unpackErr err = String (show err)+ evc err [] _ = throwError err+ evc err (cl:cls) env = do (tst,val) <- evc_clause env cl+ if tst then return val else evc err cls env+ evc_clause env (List (Symbol "else" : args)) =+ do ret <- lastOrNil (mapM (evalLisp env ql) args)+ return (True, ret)+ evc_clause env (List (pred : args)) =+ do tst <- evalLisp env ql pred+ case tst of+ Bool False -> return (False, (Bool False))+ _ -> do ret <- if isArrow args+ then evcArrow env args tst+ else lastOrNil+ (mapM (evalLisp env ql) args)+ return (True, ret)+ evc_clause _ _ = return (False, (Bool False))+ isArrow [Symbol "=>", _] = True+ isArrow _ = False+ evcArrow env [Symbol "=>", proc] val =+ evalLisp env ql proc >>= (flip (apply ql)) [val]++-- This creates an internal variable for each delay object where its value+-- will be stored once it is forced. We avoid collisions with any symbols+-- that the user might define by simply beginning the variable name with a+-- space: the parser won't let such strings through as symbols, so we are+-- never in the situation where something might clash.++evalLisp env _ (List [Symbol "delay", val]) =+ do dval <- getVar env delayCounter+ let count = getCount dval+ do setVar env delayCounter (IntNumber (count + 1))+ return (Delay val env (" delay." ++ (show count)))+ where getCount (IntNumber n) = n++evalLisp envc ql (List [Symbol "force", val]) =+ do vali <- evalLisp envc ql val+ if isDelay vali+ then do let (env, tag) = getTag vali+ alreadyDef <- liftIO (isBound env tag)+ if alreadyDef+ then getVar env tag+ else forceEval vali >>= defineVar env tag+ else return vali+ where isDelay (Delay _ _ _) = True+ isDelay _ = False+ getTag (Delay _ env tag) = (env, tag)+ forceEval (Delay obj env _) = evalLisp env ql obj++evalLisp env ql (List (Symbol "do" : List params : List test : body)) =+ if doCheck params+ then do let names = map exn params+ steps = map exs params+ inits <- mapM (evalLisp env ql) (map exi params)+ envn <- liftIO (bindVars env (zip names inits))+ doloop envn names test steps+ else errBadForm "do" params+ where exn (List [Symbol var, _]) = var+ exn (List [Symbol var, _, _]) = var+ exi (List [Symbol _, init]) = init+ exi (List [Symbol _, init, _]) = init+ exs (List [Symbol var, _]) = Symbol var+ exs (List [Symbol _, _, step]) = step+ doSet env (n,v) = setVar env n v+ doloop env names (test:rets) steps =+ do tval <- evalLisp env ql test+ if isTrue tval+ then do lastOrNil (mapM (evalLisp env ql) rets) >>= return+ else do mapM (evalLisp env ql) body+ svals <- mapM (evalLisp env ql) steps+ mapM (doSet env) (zip names svals)+ doloop env names (test:rets) steps++-- This creates a new guaranteed-never-before-used symbol (and one which+-- the user can't enter, so guaranteed no past present or future clashes).++evalLisp env _ (List [Symbol "new-symbol"]) =+ do sval <- getVar env symbolCounter+ let count = getCount sval+ do setVar env symbolCounter (IntNumber (count + 1))+ return (Symbol (" symbol." ++ (show count)))+ where getCount (IntNumber n) = n+ getCount _ = progError++-- This is not an R6RS special form, but it is a haskeem one: it needs+-- to be, because we don't want to evaluate the function name, and we+-- do want to be able to do stuff in the current environment, so that+-- we can trace just sub-functions which are defined within a function+-- but which are not visible in the top-level environment. Evaluating+-- the function name is pretty trivial, we could just require writing+-- (trace 'function #t), but tracing sub-functions needs a special+-- form, because it needs access to the current environment rather than+-- the top-level environment.++evalLisp env ql (List [Symbol "trace", Symbol var, sw]) =+ if isSpecialForm (Symbol var)+ then throwError (Default "can't trace special forms")+ else do val <- evalLisp env ql (Symbol var)+ swval <- evalLisp env ql sw+ if isPr val+ then throwError (Default "can't trace primitives")+ else if (isNF val) && (isTrue swval)+ then (remark ("trace " ++ var ++ " on")) >>+ setVar env var (trOn var val) >>+ return (Bool True)+ else if (isTF val) && (not (isTrue swval))+ then (remark ("trace " ++ var ++ " off")) >>+ setVar env var (trOff val) >>+ return (Bool True)+ else errBadForm "trace" ((Symbol var):[sw])+ where isPr (Prim _) = True+ isPr (IOPrim _) = True+ isPr _ = False+ isNF (Func _ _ _ _) = True+ isNF _ = False+ isTF (TraceFunc _ _ _ _ _) = True+ isTF _ = False+ trOn name (Func params varargs body closure) =+ (TraceFunc name params varargs body closure)+ trOn _ _ = progError+ trOff (TraceFunc _ params varargs body closure) =+ (Func params varargs body closure)+ trOff _ = progError++-- This is also not an R6RS special form, but a haskeem one: it needs+-- to be, because we want the ability to show the current environment+-- rather than just the top-level one++evalLisp env _ (List [Symbol "dump-bindings"]) = dumpEnv env stderr+evalLisp env ql (List [Symbol "dump-bindings", val]) =+ do vali <- evalLisp env ql val+ if isPort vali+ then dumpEnv env (getPort vali)+ else errBadForm "dump-bindings" [val]+ where isPort (Port _) = True+ isPort _ = False+ getPort (Port p) = p+ getPort _ = progError++-- the generic (function : args) stuff++evalLisp env ql (List (function : args)) =+ if isSpecialForm function+ then throwError (BadSpecial "bad syntax for special form" function)+ else do func <- evalLisp env ql function+ argVals <- mapM (evalLisp env ql) args+ apply ql func argVals++evalLisp _ _ badForm =+ throwError (BadSpecial "Unrecognized special form" badForm)
+ LICENSE view
@@ -0,0 +1,339 @@+ GNU GENERAL PUBLIC LICENSE+ Version 2, June 1991++ Copyright (C) 1989, 1991 Free Software Foundation, Inc.,+ 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++ Preamble++ The licenses for most software are designed to take away your+freedom to share and change it. By contrast, the GNU General Public+License is intended to guarantee your freedom to share and change free+software--to make sure the software is free for all its users. This+General Public License applies to most of the Free Software+Foundation's software and to any other program whose authors commit to+using it. (Some other Free Software Foundation software is covered by+the GNU Lesser General Public License instead.) You can apply it to+your programs, too.++ When we speak of free software, we are referring to freedom, not+price. Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+this service if you wish), that you receive source code or can get it+if you want it, that you can change the software or use pieces of it+in new free programs; and that you know you can do these things.++ To protect your rights, we need to make restrictions that forbid+anyone to deny you these rights or to ask you to surrender the rights.+These restrictions translate to certain responsibilities for you if you+distribute copies of the software, or if you modify it.++ For example, if you distribute copies of such a program, whether+gratis or for a fee, you must give the recipients all the rights that+you have. You must make sure that they, too, receive or can get the+source code. And you must show them these terms so they know their+rights.++ We protect your rights with two steps: (1) copyright the software, and+(2) offer you this license which gives you legal permission to copy,+distribute and/or modify the software.++ Also, for each author's protection and ours, we want to make certain+that everyone understands that there is no warranty for this free+software. If the software is modified by someone else and passed on, we+want its recipients to know that what they have is not the original, so+that any problems introduced by others will not reflect on the original+authors' reputations.++ Finally, any free program is threatened constantly by software+patents. We wish to avoid the danger that redistributors of a free+program will individually obtain patent licenses, in effect making the+program proprietary. To prevent this, we have made it clear that any+patent must be licensed for everyone's free use or not licensed at all.++ The precise terms and conditions for copying, distribution and+modification follow.++ GNU GENERAL PUBLIC LICENSE+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION++ 0. This License applies to any program or other work which contains+a notice placed by the copyright holder saying it may be distributed+under the terms of this General Public License. The "Program", below,+refers to any such program or work, and a "work based on the Program"+means either the Program or any derivative work under copyright law:+that is to say, a work containing the Program or a portion of it,+either verbatim or with modifications and/or translated into another+language. (Hereinafter, translation is included without limitation in+the term "modification".) Each licensee is addressed as "you".++Activities other than copying, distribution and modification are not+covered by this License; they are outside its scope. The act of+running the Program is not restricted, and the output from the Program+is covered only if its contents constitute a work based on the+Program (independent of having been made by running the Program).+Whether that is true depends on what the Program does.++ 1. You may copy and distribute verbatim copies of the Program's+source code as you receive it, in any medium, provided that you+conspicuously and appropriately publish on each copy an appropriate+copyright notice and disclaimer of warranty; keep intact all the+notices that refer to this License and to the absence of any warranty;+and give any other recipients of the Program a copy of this License+along with the Program.++You may charge a fee for the physical act of transferring a copy, and+you may at your option offer warranty protection in exchange for a fee.++ 2. You may modify your copy or copies of the Program or any portion+of it, thus forming a work based on the Program, and copy and+distribute such modifications or work under the terms of Section 1+above, provided that you also meet all of these conditions:++ a) You must cause the modified files to carry prominent notices+ stating that you changed the files and the date of any change.++ b) You must cause any work that you distribute or publish, that in+ whole or in part contains or is derived from the Program or any+ part thereof, to be licensed as a whole at no charge to all third+ parties under the terms of this License.++ c) If the modified program normally reads commands interactively+ when run, you must cause it, when started running for such+ interactive use in the most ordinary way, to print or display an+ announcement including an appropriate copyright notice and a+ notice that there is no warranty (or else, saying that you provide+ a warranty) and that users may redistribute the program under+ these conditions, and telling the user how to view a copy of this+ License. (Exception: if the Program itself is interactive but+ does not normally print such an announcement, your work based on+ the Program is not required to print an announcement.)++These requirements apply to the modified work as a whole. If+identifiable sections of that work are not derived from the Program,+and can be reasonably considered independent and separate works in+themselves, then this License, and its terms, do not apply to those+sections when you distribute them as separate works. But when you+distribute the same sections as part of a whole which is a work based+on the Program, the distribution of the whole must be on the terms of+this License, whose permissions for other licensees extend to the+entire whole, and thus to each and every part regardless of who wrote it.++Thus, it is not the intent of this section to claim rights or contest+your rights to work written entirely by you; rather, the intent is to+exercise the right to control the distribution of derivative or+collective works based on the Program.++In addition, mere aggregation of another work not based on the Program+with the Program (or with a work based on the Program) on a volume of+a storage or distribution medium does not bring the other work under+the scope of this License.++ 3. You may copy and distribute the Program (or a work based on it,+under Section 2) in object code or executable form under the terms of+Sections 1 and 2 above provided that you also do one of the following:++ a) Accompany it with the complete corresponding machine-readable+ source code, which must be distributed under the terms of Sections+ 1 and 2 above on a medium customarily used for software interchange; or,++ b) Accompany it with a written offer, valid for at least three+ years, to give any third party, for a charge no more than your+ cost of physically performing source distribution, a complete+ machine-readable copy of the corresponding source code, to be+ distributed under the terms of Sections 1 and 2 above on a medium+ customarily used for software interchange; or,++ c) Accompany it with the information you received as to the offer+ to distribute corresponding source code. (This alternative is+ allowed only for noncommercial distribution and only if you+ received the program in object code or executable form with such+ an offer, in accord with Subsection b above.)++The source code for a work means the preferred form of the work for+making modifications to it. For an executable work, complete source+code means all the source code for all modules it contains, plus any+associated interface definition files, plus the scripts used to+control compilation and installation of the executable. However, as a+special exception, the source code distributed need not include+anything that is normally distributed (in either source or binary+form) with the major components (compiler, kernel, and so on) of the+operating system on which the executable runs, unless that component+itself accompanies the executable.++If distribution of executable or object code is made by offering+access to copy from a designated place, then offering equivalent+access to copy the source code from the same place counts as+distribution of the source code, even though third parties are not+compelled to copy the source along with the object code.++ 4. You may not copy, modify, sublicense, or distribute the Program+except as expressly provided under this License. Any attempt+otherwise to copy, modify, sublicense or distribute the Program is+void, and will automatically terminate your rights under this License.+However, parties who have received copies, or rights, from you under+this License will not have their licenses terminated so long as such+parties remain in full compliance.++ 5. You are not required to accept this License, since you have not+signed it. However, nothing else grants you permission to modify or+distribute the Program or its derivative works. These actions are+prohibited by law if you do not accept this License. Therefore, by+modifying or distributing the Program (or any work based on the+Program), you indicate your acceptance of this License to do so, and+all its terms and conditions for copying, distributing or modifying+the Program or works based on it.++ 6. Each time you redistribute the Program (or any work based on the+Program), the recipient automatically receives a license from the+original licensor to copy, distribute or modify the Program subject to+these terms and conditions. You may not impose any further+restrictions on the recipients' exercise of the rights granted herein.+You are not responsible for enforcing compliance by third parties to+this License.++ 7. If, as a consequence of a court judgment or allegation of patent+infringement or for any other reason (not limited to patent issues),+conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License. If you cannot+distribute so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you+may not distribute the Program at all. For example, if a patent+license would not permit royalty-free redistribution of the Program by+all those who receive copies directly or indirectly through you, then+the only way you could satisfy both it and this License would be to+refrain entirely from distribution of the Program.++If any portion of this section is held invalid or unenforceable under+any particular circumstance, the balance of the section is intended to+apply and the section as a whole is intended to apply in other+circumstances.++It is not the purpose of this section to induce you to infringe any+patents or other property right claims or to contest validity of any+such claims; this section has the sole purpose of protecting the+integrity of the free software distribution system, which is+implemented by public license practices. Many people have made+generous contributions to the wide range of software distributed+through that system in reliance on consistent application of that+system; it is up to the author/donor to decide if he or she is willing+to distribute software through any other system and a licensee cannot+impose that choice.++This section is intended to make thoroughly clear what is believed to+be a consequence of the rest of this License.++ 8. If the distribution and/or use of the Program is restricted in+certain countries either by patents or by copyrighted interfaces, the+original copyright holder who places the Program under this License+may add an explicit geographical distribution limitation excluding+those countries, so that distribution is permitted only in or among+countries not thus excluded. In such case, this License incorporates+the limitation as if written in the body of this License.++ 9. The Free Software Foundation may publish revised and/or new versions+of the General Public License from time to time. Such new versions will+be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++Each version is given a distinguishing version number. If the Program+specifies a version number of this License which applies to it and "any+later version", you have the option of following the terms and conditions+either of that version or of any later version published by the Free+Software Foundation. If the Program does not specify a version number of+this License, you may choose any version ever published by the Free Software+Foundation.++ 10. If you wish to incorporate parts of the Program into other free+programs whose distribution conditions are different, write to the author+to ask for permission. For software which is copyrighted by the Free+Software Foundation, write to the Free Software Foundation; we sometimes+make exceptions for this. Our decision will be guided by the two goals+of preserving the free status of all derivatives of our free software and+of promoting the sharing and reuse of software generally.++ NO WARRANTY++ 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,+REPAIR OR CORRECTION.++ 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE+POSSIBILITY OF SUCH DAMAGES.++ END OF TERMS AND CONDITIONS++ How to Apply These Terms to Your New Programs++ If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++ To do so, attach the following notices to the program. It is safest+to attach them to the start of each source file to most effectively+convey the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++ <one line to give the program's name and a brief idea of what it does.>+ Copyright (C) <year> <name of author>++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License along+ with this program; if not, write to the Free Software Foundation, Inc.,+ 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.++Also add information on how to contact you by electronic and paper mail.++If the program is interactive, make it output a short notice like this+when it starts in an interactive mode:++ Gnomovision version 69, Copyright (C) year name of author+ Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.+ This is free software, and you are welcome to redistribute it+ under certain conditions; type `show c' for details.++The hypothetical commands `show w' and `show c' should show the appropriate+parts of the General Public License. Of course, the commands you use may+be called something other than `show w' and `show c'; they could even be+mouse-clicks or menu items--whatever suits your program.++You should also get your employer (if you work as a programmer) or your+school, if any, to sign a "copyright disclaimer" for the program, if+necessary. Here is a sample; alter the names:++ Yoyodyne, Inc., hereby disclaims all copyright interest in the program+ `Gnomovision' (which makes passes at compilers) written by James Hacker.++ <signature of Ty Coon>, 1 April 1989+ Ty Coon, President of Vice++This General Public License does not permit incorporating your program into+proprietary programs. If your program is a subroutine library, you may+consider it more useful to permit linking proprietary applications with the+library. If this is what you want to do, use the GNU Lesser General+Public License instead of this License.
+ Library.hs view
@@ -0,0 +1,1483 @@+{- Copyright 2008 Uwe Hollerbach <uh@alumni.caltech.edu>+Portions of this were derived from Jonathan Tang's haskell+tutorial "Write yourself a scheme in 48 hours" and are thus+Copyright Jonathan Tang+(but I can't easily tell anymore who originally wrote what)++This file is part of haskeem.+haskeem is free software; you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation; either version 2 of the License, or+(at your option) any later version.++haskeem is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+GNU General Public License for more details.++You should have received a copy of the GNU General Public License+along with haskeem; if not, write to the Free Software+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA++$Id: library.hs,v 1.26 2009-05-31 01:41:08 uwe Exp $ -}++module Library (primitiveBindings, delayCounter, symbolCounter, loadFile, eqv)+ where+import Prelude+import IO+import Data.Char+import Data.Ratio+import Control.Monad.Error as CME+import Data.IORef+import System.Directory+import System.Posix.Env+import System.Posix.Files+import System.Posix.Types()+import System.Exit+import System.Time+import System.CPUTime+import System.Random+import qualified Data.IntMap as DIM+import Network++import LispData+import Parser+import Environment+import WriteNumber++errNumArgs name want got = throwError (NumArgs name want got)+errTypeMismatch name want got = throwError (TypeMismatch name want got)++genericBadArg :: [LispVal] -> String -> String -> Int+ -> ThrowsError LispVal+genericBadArg badArgList func want num =+ if num < 0 || length badArgList == num+ then errTypeMismatch func want (List badArgList)+ else errNumArgs func (toInteger num) badArgList++genericIOBadArg :: [LispVal] -> String -> String -> Int+ -> IOThrowsError LispVal+genericIOBadArg badArgList func want num =+ if length badArgList == num+ then errTypeMismatch func want (badArgList !! 0)+ else errNumArgs func (toInteger num) badArgList++-- A bunch of library functions that don't do IO:+-- these get put into the primitives table below++isChar :: [LispVal] -> ThrowsError LispVal+isChar [Char _] = return (Bool True)+isChar _ = return (Bool False)++isBool :: [LispVal] -> ThrowsError LispVal+isBool [Bool _] = return (Bool True)+isBool _ = return (Bool False)++isNumber :: [LispVal] -> ThrowsError LispVal+isNumber [IntNumber _] = return (Bool True)+isNumber [RatNumber _] = return (Bool True)+isNumber [FltNumber _] = return (Bool True)+isNumber _ = return (Bool False)++isInteger :: [LispVal] -> ThrowsError LispVal+isInteger [IntNumber _] = return (Bool True)+isInteger [RatNumber n] = return (Bool ((denominator n) == 1))+isInteger _ = return (Bool False)++isRational :: [LispVal] -> ThrowsError LispVal+isRational [IntNumber _] = return (Bool True)+isRational [RatNumber _] = return (Bool True)+isRational _ = return (Bool False)++isReal :: [LispVal] -> ThrowsError LispVal+isReal [IntNumber _] = return (Bool True)+isReal [RatNumber _] = return (Bool True)+isReal [FltNumber _] = return (Bool True)+isReal _ = return (Bool False)++isString :: [LispVal] -> ThrowsError LispVal+isString [String _] = return (Bool True)+isString _ = return (Bool False)++isSymbol :: [LispVal] -> ThrowsError LispVal+isSymbol [Symbol _] = return (Bool True)+isSymbol _ = return (Bool False)++isList :: [LispVal] -> ThrowsError LispVal+isList [List _] = return (Bool True)+isList _ = return (Bool False)++isPair :: [LispVal] -> ThrowsError LispVal+isPair [List []] = return (Bool False)+isPair [List _] = return (Bool True)+isPair [DottedList _ _] = return (Bool True)+isPair _ = return (Bool False)++isPort :: [LispVal] -> ThrowsError LispVal+isPort [Port _] = return (Bool True)+isPort [Socket _] = return (Bool True)+isPort _ = return (Bool False)++isProcedure :: [LispVal] -> ThrowsError LispVal+isProcedure [Prim _] = return (Bool True)+isProcedure [IOPrim _] = return (Bool True)+isProcedure [Func _ _ _ _] = return (Bool True)+isProcedure [TraceFunc _ _ _ _ _] = return (Bool True)+isProcedure _ = return (Bool False)++isVector :: [LispVal] -> ThrowsError LispVal+isVector [Vector _ _] = return (Bool True)+isVector _ = return (Bool False)++isNull :: [LispVal] -> ThrowsError LispVal+isNull [List []] = return (Bool True)+isNull _ = return (Bool False)++isZero :: [LispVal] -> ThrowsError LispVal+isZero [IntNumber n] =+ if n == 0 then return (Bool True) else return (Bool False)+isZero [RatNumber n] =+ if (n == 0) then return (Bool True) else return (Bool False)+isZero [FltNumber n] =+ if n == 0 then return (Bool True) else return (Bool False)+isZero _ = return (Bool False)++isPositive :: [LispVal] -> ThrowsError LispVal+isPositive [IntNumber n] =+ if n > 0 then return (Bool True) else return (Bool False)+isPositive [RatNumber n] =+ if n > 0 then return (Bool True) else return (Bool False)+isPositive [FltNumber n] =+ if n > 0 then return (Bool True) else return (Bool False)+isPositive _ = return (Bool False)++isNegative :: [LispVal] -> ThrowsError LispVal+isNegative [IntNumber n] =+ if n < 0 then return (Bool True) else return (Bool False)+isNegative [RatNumber n] =+ if n < 0 then return (Bool True) else return (Bool False)+isNegative [FltNumber n] =+ if n < 0 then return (Bool True) else return (Bool False)+isNegative _ = return (Bool False)++-- The treatment of Inf and NaN is not quite according to R6RS here. they say+-- (/ 1 0) causes an exception, but I can't find what happens if the parser+-- sees the number 1/0. I think it ought to be Inf, or perhaps RatInf. So I'm+-- going to return true for isInf for the rational numbers 1/0 and -1/0, and+-- true for isNaN for 0/0, allow entering of both (/ 1 0) and 1/0 plus ninf+-- and nan, and deal with these when they arise in computations++lispIsNaN :: [LispVal] -> ThrowsError LispVal+lispIsNaN [RatNumber n] =+ return (Bool (((numerator n) == 0) && ((denominator n) == 0)))+lispIsNaN [FltNumber n] = return (Bool (isNaN n))+lispIsNaN _ = return (Bool False)++lispIsInf :: [LispVal] -> ThrowsError LispVal+lispIsInf [RatNumber n] = + return (Bool (((numerator n) /= 0) && ((denominator n) == 0)))+lispIsInf [FltNumber n] = return (Bool (isInfinite n))+lispIsInf _ = return (Bool False)++lispIsFinite :: [LispVal] -> ThrowsError LispVal+lispIsFinite [IntNumber _] = return (Bool True)+lispIsFinite [RatNumber n] = return (Bool ((denominator n) /= 0))+lispIsFinite [FltNumber n] =+ return (Bool (not ((isInfinite n) && (isNaN n))))+lispIsFinite _ = return (Bool False)++lispIsEven :: [LispVal] -> ThrowsError LispVal+lispIsEven [IntNumber n] | even n = return (Bool True)+ | otherwise = return (Bool False)+lispIsEven _ = return (Bool False)++lispIsOdd :: [LispVal] -> ThrowsError LispVal+lispIsOdd [IntNumber n] | even n = return (Bool False)+ | otherwise = return (Bool True)+lispIsOdd _ = return (Bool False)++lispId :: [LispVal] -> ThrowsError LispVal+lispId [val@(_)] = return val++lispNot :: [LispVal] -> ThrowsError LispVal+lispNot [Bool False] = return (Bool True)+lispNot _ = return (Bool False)++unpackChar :: LispVal -> ThrowsError Char+unpackChar (Char c) = return c+unpackChar notChar = errTypeMismatch "<unpackChar>" "character" notChar++unpackIntNum :: LispVal -> ThrowsError Integer+unpackIntNum (IntNumber n) = return n+unpackIntNum (RatNumber n) =+ if (denominator n) /= 0+ then return (truncate n)+ else errTypeMismatch "<unpackIntNum>" "number" (RatNumber n)+unpackIntNum (FltNumber n) = return (truncate n)+unpackIntNum (List [n]) = unpackIntNum n+unpackIntNum notNum = errTypeMismatch "<unpackIntNum>" "number" notNum++unpackRatNum :: LispVal -> ThrowsError Rational+unpackRatNum (IntNumber n) = return (fromInteger n)+unpackRatNum (RatNumber n) = return n+unpackRatNum (FltNumber n) = return (toRational n)+unpackRatNum (List [n]) = unpackRatNum n+unpackRatNum notNum = errTypeMismatch "<unpackRatNum>" "number" notNum++unpackFltNum :: LispVal -> ThrowsError Double+unpackFltNum (IntNumber n) = return (fromInteger n)+unpackFltNum (RatNumber n) = return (fromRational n)+unpackFltNum (FltNumber n) = return n+unpackFltNum (List [n]) = unpackFltNum n+unpackFltNum notNum = errTypeMismatch "<unpackFltNum>" "number" notNum++unpackStr :: LispVal -> ThrowsError String+unpackStr (String s) = return s+unpackStr (IntNumber n) = return (show n)+unpackStr (RatNumber n) = return (show n)+unpackStr (FltNumber n) = return (show n)+unpackStr (Bool b) = return (show b)+unpackStr notString = errTypeMismatch "<unpackStr>" "string" notString++-- first cut at "number tower": if we have a set of args that are all+-- integers, we want to keep everything as an integer, including the result;+-- if there's a rational in there somewhere, promote them all to rationals;+-- ditto for doubles.++isIntType, isRatType, isFltType, isOther :: Int+isIntType = 0+isRatType = 1+isFltType = 2+isOther = 3++libRatNaN, libFltNaN, libRatPInf :: LispVal+libRatNaN = RatNumber myRatNaN+libFltNaN = FltNumber myFltNaN+libRatPInf = RatNumber myRatPInf++scanRatNaN :: [LispVal] -> Bool+scanRatNaN [] = False+scanRatNaN (IntNumber _:vs) = scanRatNaN vs+scanRatNaN (RatNumber v:vs) = if v == myRatNaN then True else scanRatNaN vs++scanFltNaN :: [LispVal] -> Bool+scanFltNaN [] = False+scanFltNaN (IntNumber _:vs) = scanFltNaN vs+scanFltNaN (RatNumber v:vs) = if v == myRatNaN then True else scanFltNaN vs+scanFltNaN (FltNumber v:vs) = if isNaN v then True else scanFltNaN vs++getType :: [LispVal] -> Int+getType p = foldl1 max (map g p)+ where g (IntNumber _) = isIntType+ g (RatNumber _) = isRatType+ g (FltNumber _) = isFltType+ g _ = isOther++isNumType :: Int -> Bool+isNumType n = (n == isIntType || n == isRatType || n == isFltType)++intOrRat :: Rational -> LispVal+intOrRat n | (denominator n) == 1 = (IntNumber (numerator n))+ | otherwise = (RatNumber n)++numericBinop :: String -> (Integer -> Integer -> Integer) ->+ (Rational -> Rational -> Rational) ->+ (Double -> Double -> Double) ->+ [LispVal] -> ThrowsError LispVal+numericBinop name intOp ratOp dblOp av =+ do let mytype = getType av+ if length av < 2+ then errNumArgs name 2 ((String (show (length av))) : av)+ else if mytype == isIntType+ then mapM unpackIntNum av >>=+ return . IntNumber . foldl1 intOp+ else if mytype == isRatType+ then if scanRatNaN av+ then return libRatNaN+ else mapM unpackRatNum av >>=+ return . intOrRat . foldl1 ratOp+ else if mytype == isFltType+ then if scanFltNaN av+ then return libFltNaN+ else mapM unpackFltNum av >>=+ return . FltNumber . foldl1 dblOp+ else errTypeMismatch name "number" (List av)++integerBinop :: String -> (Integer -> Integer -> Integer) ->+ [LispVal] -> ThrowsError LispVal+integerBinop name intOp av =+ do let mytype = getType av+ if length av < 2+ then errNumArgs name 2 av+ else if mytype == isIntType+ then mapM unpackIntNum av >>=+ return . IntNumber . foldl1 intOp+ else errTypeMismatch name "number" (List av)++numBoolBinop :: String -> (Integer -> Integer -> Bool) ->+ (Rational -> Rational -> Bool) ->+ (Double -> Double -> Bool) ->+ Bool -> [LispVal] -> ThrowsError LispVal+numBoolBinop name intOp ratOp dblOp nanval av =+ do let mytype = getType av+ if length av < 2+ then errNumArgs name 2 av+ else if mytype == isIntType+ then do ll <- unpackIntNum (av !! 0)+ rr <- unpackIntNum (av !! 1)+ return (Bool (intOp ll rr))+ else if mytype == isRatType+ then if scanRatNaN av+ then return (Bool nanval)+ else do ll <- unpackRatNum (av !! 0)+ rr <- unpackRatNum (av !! 1)+ return (Bool (ratOp ll rr))+ else if mytype == isFltType+ then if scanFltNaN av+ then return (Bool nanval)+ else do ll <- unpackFltNum (av !! 0)+ rr <- unpackFltNum (av !! 1)+ return (Bool (dblOp ll rr))+ else errTypeMismatch name "number" (List av)++numericFunc :: String -> (Double -> Double) -> [LispVal] -> ThrowsError LispVal+numericFunc name fun av =+ do let mytype = getType av+ if length av /= 1+ then errNumArgs name 1 av+ else if isNumType mytype+ then if scanFltNaN av+ then return libFltNaN+ else unpackFltNum (av !! 0) >>=+ return . FltNumber . fun+ else errTypeMismatch name "number" (List av)++lispNumerator :: [LispVal] -> ThrowsError LispVal+lispNumerator [IntNumber n] = return (IntNumber n)+lispNumerator [RatNumber n] = return (IntNumber (numerator n))+lispNumerator (val:[]) = errTypeMismatch "-" "number" (String (show val))+lispNumerator badArgList =+ genericBadArg badArgList "numerator" "integer or rational" 1++lispDenominator :: [LispVal] -> ThrowsError LispVal+lispDenominator [IntNumber _] = return (IntNumber 1)+lispDenominator [RatNumber n] = return (IntNumber (denominator n))+lispDenominator (val:[]) = errTypeMismatch "-" "number" (String (show val))+lispDenominator badArgList =+ genericBadArg badArgList "denominator" "integer or rational" 1++-- I want haskeem to be able to deal with rational-number infinities and+-- nans, so this stuff works around haskell's normalization of rational+-- numbers, which breaks for non-finite numbers like 1/0 or 0/0.++-- There are some asymmetries in these case tables, arising from the fact+-- that there are positive and negative infinities, but not also positive+-- and negative zero; so for example the reciprocal of -inf is 0, and thus+-- (reciprocal (reciprocal -inf)) is +inf rather than -inf. In that respect,+-- rational infs and nan aren't numbers; but then, they are also not+-- number-like in that they are their own successors: inf + 1 = inf. One of+-- the SRFIs points this out as a reason to only have inexact, ie+-- floating-point, infinities and NaNs; but I still prefer to have+-- rational-format infinities and NaNs when all calculations are only+-- integers and rationals: if the final answer in such a calculation comes+-- out finite, ie by dividing by an infinity, it will remain an exact+-- quantity; that is mathematically correct, but would not be the case if+-- infinities were necessarily inexact.++myrecip :: Rational -> Rational+myrecip n | n == myRatNaN = myRatNaN+ | (n == myRatPInf || n == myRatNInf) = 0+ | n == 0 = myRatPInf+ | otherwise = (recip n)++mymul :: Rational -> Rational -> Rational+mymul n1 n2 | ((denominator n1 /= 0) &&+ (denominator n2 /= 0)) = n1 * n2+ | (n1 == myRatNaN || n2 == myRatNaN) ||+ (n1 == 0 && (n2 == myRatPInf ||+ n2 == myRatNInf)) ||+ (n2 == 0 && (n1 == myRatPInf ||+ n1 == myRatNInf)) = myRatNaN+ | (sg n1) == (sg n2) = myRatPInf+ | otherwise = myRatNInf+ where sg n = if n > 0 then 1 else -1++myadd :: Rational -> Rational -> Rational+myadd n1 n2 | ((denominator n1 /= 0) &&+ (denominator n2 /= 0)) = n1 + n2+ | (n1 == myRatNaN || n2 == myRatNaN) ||+ (n1 == myRatPInf && n2 == myRatNInf) ||+ (n1 == myRatNInf && n2 == myRatPInf) = myRatNaN+ | (denominator n1 /= 0) = n2+ | otherwise = n1++mypow :: Rational -> Integer -> Rational+mypow b e | (b == myRatNaN) = myRatNaN+ | (b == myRatPInf && e > 0) = myRatPInf+ | (b == myRatPInf && e == 0) = myRatNaN+ | (b == myRatNInf && e > 0 && even e) = myRatPInf+ | (b == myRatNInf && e > 0 && odd e) = myRatNInf+ | (b == myRatNInf && e == 0) = myRatNaN+ | (b == 0 && e > 0) = 0+ | (e == 0) = 1 -- including 0**0,+ -- mandated by R6RS+ | (e < 0) = mypow (myrecip b) (negate e)+ | otherwise = b ^ e++addOp = numericBinop "+" (+) myadd (+)+mulOp = numericBinop "*" (*) mymul (*)++lispPlus :: [LispVal] -> ThrowsError LispVal+lispPlus [] = return (IntNumber 0)+lispPlus [IntNumber n] = return (IntNumber n)+lispPlus [RatNumber n] = return (RatNumber n)+lispPlus [FltNumber n] = return (FltNumber n)+lispPlus (val:[]) = errTypeMismatch "+" "number" (String (show val))+lispPlus (v:vs) = addOp (v:vs)++lispMinus :: [LispVal] -> ThrowsError LispVal+lispMinus [IntNumber n] = return (IntNumber (negate n))+lispMinus [RatNumber n] = return (RatNumber (negate n))+lispMinus [FltNumber n] = return (FltNumber (negate n))+lispMinus (val:[]) = errTypeMismatch "-" "number" (String (show val))+lispMinus (a:as) =+ do aux <- addOp ((IntNumber 0):as)+ rec <- lispMinus [aux]+ res <- addOp (a:[rec])+ return res++lispMul :: [LispVal] -> ThrowsError LispVal+lispMul [] = return (IntNumber 1)+lispMul [IntNumber n] = return (IntNumber n)+lispMul [RatNumber n] = return (RatNumber n)+lispMul [FltNumber n] = return (FltNumber n)+lispMul (val:[]) = errTypeMismatch "*" "number" (String (show val))+lispMul (v:vs) = mulOp (v:vs)++lispDiv :: [LispVal] -> ThrowsError LispVal+lispDiv [IntNumber n] = return (RatNumber (myrecip (fromInteger n)))+lispDiv [RatNumber n] =+ let nr = myrecip n+ in if (denominator nr) == 1+ then return (IntNumber (numerator nr))+ else return (RatNumber nr)+lispDiv [FltNumber n] = return (FltNumber (1.0 / n))+lispDiv (val:[]) = errTypeMismatch "/" "number" (String (show val))+lispDiv (a:as) =+ do aux <- mulOp ((IntNumber 1):as)+ rec <- lispDiv [aux]+ res <- mulOp (a:[rec])+ return res++lispMin :: [LispVal] -> ThrowsError LispVal+lispMin [] = errNumArgs "min" 1 []+lispMin [IntNumber n] = return (IntNumber n)+lispMin [RatNumber n] = return (RatNumber n)+lispMin [FltNumber n] = return (FltNumber n)+lispMin (val:[]) = errTypeMismatch "min" "number" (String (show val))+lispMin (a:as) = numericBinop "min" min min min (a:as)++lispMax :: [LispVal] -> ThrowsError LispVal+lispMax [] = errNumArgs "max" 1 []+lispMax [IntNumber n] = return (IntNumber n)+lispMax [RatNumber n] = return (RatNumber n)+lispMax [FltNumber n] = return (FltNumber n)+lispMax (val:[]) = errTypeMismatch "max" "number" (String (show val))+lispMax (a:as) = numericBinop "max" max max max (a:as)++fltpow :: Double -> Double -> LispVal+fltpow x y | y == 0 = IntNumber 1+ | (x == 0 && y > 0) = IntNumber 0+ | (x == 0 && y < 0) = libRatPInf+ | ((abs x) < 1 && y > 0 && isInfinite y) = IntNumber 0+ | ((abs x) > 1 && y < 0 && isInfinite y) = IntNumber 0+ | otherwise = FltNumber (x ** y)++spow :: Rational -> Rational -> LispVal+spow x y | x < -1 && y == myRatPInf = libRatNaN+ | x < 0 && x > -1 && y == myRatNInf = libRatNaN+ | x == -1 && (abs y) == myRatPInf = libRatNaN+ | x == myRatNInf && y > 0 && (denominator y) > 1 = libRatNaN+ | (abs x) == myRatPInf && y > 0 = libRatPInf+ | x > 1 && y == myRatPInf = libRatPInf+ | x > 0 && x < 1 && y == myRatNInf = libRatPInf+ | (abs x) == myRatPInf && y < 0 = IntNumber 0+ | x == 1 = IntNumber 1+ | otherwise = fltpow (fromRational x) (fromRational y)++ratpow :: Rational -> Rational -> LispVal+ratpow x y =+ if (denominator y) == 1+ then let pow = mypow x (numerator y)+ in if (denominator pow) == 1+ then (IntNumber (numerator pow))+ else (RatNumber pow)+ else (spow x y)++lispPow :: [LispVal] -> ThrowsError LispVal+lispPow av =+ if length av /= 2+ then do errNumArgs "**" 2 av+ else do let mytype = getType av+ if isNumType mytype+ then if (mytype == isIntType || mytype == isRatType)+ then if scanRatNaN av+ then return libRatNaN+ else do b <- unpackRatNum (av !! 0)+ e <- unpackRatNum (av !! 1)+ return (ratpow b e)+ else if scanFltNaN av+ then return libFltNaN+ else do b <- unpackFltNum (av !! 0)+ e <- unpackFltNum (av !! 1)+ return (fltpow b e)+ else errTypeMismatch "expt" "number" (List av)++boolBinop :: (LispVal -> ThrowsError a) -> String -> (a -> a -> Bool) ->+ [LispVal] -> ThrowsError LispVal+boolBinop unpacker name op args =+ if length args /= 2+ then errNumArgs name 2 args+ else do ll <- unpacker (args !! 0)+ rr <- unpacker (args !! 1)+ return (Bool (ll `op` rr))++strBoolBinop = boolBinop unpackStr+charBoolBinop = boolBinop unpackChar++car :: [LispVal] -> ThrowsError LispVal+car [List (x:_)] = return x+car [DottedList (x:_) _] = return x+car badArgList = genericBadArg badArgList "car" "pair or list" 1++cdr :: [LispVal] -> ThrowsError LispVal+cdr [List (_:xs)] = return (List xs)+cdr [DottedList (_:[]) x] = return x+cdr [DottedList (_:xs) x] = return (DottedList xs x)+cdr badArgList = genericBadArg badArgList "cdr" "pair or list" 1++cons :: [LispVal] -> ThrowsError LispVal+cons [xl, List []] = return (List [xl])+cons [x, List xs] = return (List ([x] ++ xs))+cons [x, DottedList xs xl] = return (DottedList ([x] ++ xs) xl)+cons [x1, x2] = return (DottedList [x1] x2)+cons badArgList = errNumArgs "cons" 2 badArgList++eqv :: [LispVal] -> Bool+eqv [(Bool v1), (Bool v2)] = (v1 == v2)+eqv [(Char c1), (Char c2)] = (c1 == c2)+eqv [(IntNumber v1), (IntNumber v2)] = (v1 == v2)+eqv [(RatNumber v1), (RatNumber v2)] = (v1 == v2)+eqv [(FltNumber v1), (FltNumber v2)] = (v1 == v2) || ((isNaN v1) && (isNaN v2))+eqv [(String v1), (String v2)] = (v1 == v2)+eqv [(Symbol v1), (Symbol v2)] = (v1 == v2)+eqv [(DottedList l1 t1), (DottedList l2 t2)] =+ eqv [(List (l1 ++ [t1])), (List (l2 ++ [t2]))]+eqv [(List l1), (List l2)] =+ ((length l1 == length l2) && (and (map eqvPair (zip l1 l2))))+ where eqvPair (x1,x2) = eqv [x1,x2]+eqv [(Vector l1 v1), (Vector l2 v2)] =+ ((l1 == l2) && (and (map eqvPair (zip (getval (DIM.toAscList v1))+ (getval (DIM.toAscList v2))))))+ where eqvPair (x1,x2) = eqv [x1,x2]+ getval [] = []+ getval ((_,v):vs) = v:(getval vs)+eqv _ = False++eqvFunc :: [LispVal] -> ThrowsError LispVal+eqvFunc (v1:v2:[]) = return (Bool (eqv [v1,v2]))+eqvFunc badArgList = genericBadArg badArgList "eqv?" "matched types" 2++char2int :: [LispVal] -> ThrowsError LispVal+char2int [Char c] = return (IntNumber (toInteger (ord c)))+char2int badArgList = genericBadArg badArgList "char->integer" "character" 1++int2char :: [LispVal] -> ThrowsError LispVal+int2char [IntNumber c] = return (Char (chr (fromInteger c)))+int2char badArgList = genericBadArg badArgList "integer->char" "integer" 1++char2str :: [LispVal] -> ThrowsError LispVal+char2str [] = return (String "")+char2str [List chars] = char2str chars+char2str chars = mapM unpackChar chars >>= return . String . (foldr (:) [])++str2char :: [LispVal] -> ThrowsError LispVal+str2char [] = return (List [])+str2char [String s] = return (List (map Char s))+str2char badArgList = genericBadArg badArgList "string->char" "string" 1++symb2str :: [LispVal] -> ThrowsError LispVal+symb2str [] = return (String "")+symb2str [Symbol s] = return (String s)+symb2str badArgList = genericBadArg badArgList "symbol->string" "string" 1++readNum :: [LispVal] -> ThrowsError LispVal+readNum [String s] = readNumber s+readNum badArgList = genericBadArg badArgList "string->number" "string" 1++charIs :: (Char -> Bool) -> [LispVal] -> ThrowsError LispVal+charIs op [Char c] = return (Bool (op c))+charIs _ badArgList = genericBadArg badArgList "char-istype?" "character" 1++charTo :: (Char -> Char) -> [LispVal] -> ThrowsError LispVal+charTo op [Char char] = return (Char (op char))+charTo op [List chars] = charTo op chars+charTo op [String str] = return (String (map op str))+charTo op chars =+ mapM oneTo chars >>= return . List+ where oneTo (Char c) = return (Char (op c))+ oneTo notChar = errTypeMismatch "charTo" "character" notChar++lispFloor :: [LispVal] -> ThrowsError LispVal+lispFloor [IntNumber c] = return (IntNumber c)+lispFloor [RatNumber c] =+ if (denominator c) /= 0+ then return (IntNumber (floor c))+ else return (RatNumber c)+lispFloor [FltNumber c] = return (IntNumber (floor c))+lispFloor badArgList = genericBadArg badArgList "floor" "number" 1++lispTruncate :: [LispVal] -> ThrowsError LispVal+lispTruncate [IntNumber c] = return (IntNumber c)+lispTruncate [RatNumber c] =+ if (denominator c) /= 0+ then return (IntNumber (truncate c))+ else return (RatNumber c)+lispTruncate [FltNumber c] = return (IntNumber (truncate c))+lispTruncate badArgList = genericBadArg badArgList "truncate" "number" 1++-- TODO: implement relative-tolerance rounding, so that specifying+-- 3 digits relative gives X.XXXeXX, for any exponent++-- round to a {rational,floating-point} number with a specified non-negative+-- number of digits to the right of the decimal point; this is a number of+-- the same type as the input++roundToAP :: RealFrac a => a -> Integer -> Integer -> a+roundToAP n b d =+ let bd = (fromInteger (b^d))+ in (fromInteger (round (n * bd)))/bd++-- equivalent of the above, except with the truncation point to the left+-- of the decimal point; that means the result is always an integer++roundToAN :: RealFrac a => a -> Integer -> Integer -> Integer+roundToAN n b d =+ let bd = b^d+ in bd*(round (n/(fromInteger bd)))++lispRound :: [LispVal] -> ThrowsError LispVal+lispRound [IntNumber c] = return (IntNumber c)+lispRound [RatNumber c] =+ if (denominator c) /= 0+ then return (IntNumber (round c))+ else return (RatNumber c)+lispRound [FltNumber c] = return (IntNumber (round c))+lispRound [IntNumber c, IntNumber b, IntNumber d] =+ if b > 1+ then if d >= 0+ then return (IntNumber c)+ else return (IntNumber (roundToAN (toRational c) b (- d)))+ else throwError (Default ("bad base arg to round: " ++ (show b)))+lispRound [RatNumber c, IntNumber b, IntNumber d] =+ if (denominator c) /= 0+ then if b > 1+ then if d > 0+ then return (RatNumber (roundToAP c b d))+ else return (IntNumber (roundToAN c b (- d)))+ else throwError (Default ("bad base arg to round: " ++ (show b)))+ else return (RatNumber c)+lispRound [FltNumber c, IntNumber b, IntNumber d] =+ if b > 1+ then if d > 0+ then return (FltNumber (roundToAP c b d))+ else return (IntNumber (roundToAN c b (- d)))+ else throwError (Default ("bad base arg to round: " ++ (show b)))+lispRound badArgList = genericBadArg badArgList "round" "number" 1++lispCeiling :: [LispVal] -> ThrowsError LispVal+lispCeiling [IntNumber c] = return (IntNumber c)+lispCeiling [RatNumber c] =+ if (denominator c) /= 0+ then return (IntNumber (ceiling c))+ else return (RatNumber c)+lispCeiling [FltNumber c] = return (IntNumber (ceiling c))+lispCeiling badArgList = genericBadArg badArgList "ceiling" "number" 1++lispAbs :: [LispVal] -> ThrowsError LispVal+lispAbs [IntNumber c] = return (IntNumber (abs c))+lispAbs [RatNumber n] = return (RatNumber (abs n))+lispAbs [FltNumber c] = return (FltNumber (abs c))+lispAbs badArgList = genericBadArg badArgList "abs" "number" 1++lispATan2 :: [LispVal] -> ThrowsError LispVal+lispATan2 av =+ do let mytype = getType av+ if isNumType mytype+ then if scanFltNaN av+ then return libFltNaN+ else case length av of+ 1 -> mapM unpackFltNum av >>=+ return . FltNumber . atan . head+ 2 -> mapM unpackFltNum av >>=+ return . FltNumber . at2+ _ -> errNumArgs "atan" 2 av+ else errTypeMismatch "atan" "number" (List av)+ where at2 (y:x:[]) = atan2 y x++lispListFromArgs :: [LispVal] -> ThrowsError LispVal+lispListFromArgs vals = return (List vals)++lispReverse :: [LispVal] -> ThrowsError LispVal+lispReverse [List lst] = return (List (reverse lst))+lispReverse badArgList = genericBadArg badArgList "reverse" "list" 1++lispLast :: [LispVal] -> ThrowsError LispVal+lispLast [List []] = return (List [])+lispLast [List lst] = return (last lst)+lispLast badArgList = genericBadArg badArgList "last" "list" 1++lispLength :: [LispVal] -> ThrowsError LispVal+lispLength [List lst] = return (IntNumber (toInteger (length lst)))+lispLength badArgList = genericBadArg badArgList "length" "list" 1++lispListHead :: [LispVal] -> ThrowsError LispVal+lispListHead [List lst, IntNumber n] = return (List (take (fromInteger n) lst))+lispListHead badArgList =+ genericBadArg badArgList "list-head" "list + number" 2++lispListTail :: [LispVal] -> ThrowsError LispVal+lispListTail [List lst, IntNumber n] = return (List (drop (fromInteger n) lst))+lispListTail badArgList =+ genericBadArg badArgList "list-tail" "list + number" 2++lispListRef :: [LispVal] -> ThrowsError LispVal+lispListRef [List lst, IntNumber n] =+ return (hON (drop (fromInteger n) lst))+ where hON [] = List []+ hON (x:_) = x+lispListRef badArgList = genericBadArg badArgList "list-ref" "list + number" 2++lispILog :: [LispVal] -> ThrowsError LispVal+lispILog [IntNumber n] = return (IntNumber (ilogb 2 n))+lispILog [IntNumber b, IntNumber n] =+ if b < 2+ then errTypeMismatch "ilog" "b > 2" (IntNumber b)+ else return (IntNumber (ilogb b n))+lispILog badArgList = genericBadArg badArgList "ilog" "integer" 1++lispFactorial :: [LispVal] -> ThrowsError LispVal+lispFactorial [IntNumber n] =+ if n > 0+ then return (IntNumber (product [1 .. n]))+ else if n == 0+ then return (IntNumber 1)+ else genericBadArg [IntNumber n] "factorial"+ "non-negative integer" 1+lispFactorial badArgList = genericBadArg badArgList "factorial" "integer" 1++-- Vector primitives++lispMakeVector :: [LispVal] -> ThrowsError LispVal+lispMakeVector [IntNumber n] = lispMakeVector [IntNumber n, Bool False]+lispMakeVector [IntNumber n, val] =+ if n > 0+ then return (Vector n (DIM.fromAscList (addkey val (fromInteger n))))+ else errTypeMismatch "make-vector" "n > 0" (IntNumber n)+ where addkey _ 0 = []+ addkey v k = ((k-1), v):(addkey v (k-1))+lispMakeVector badArgList = genericBadArg badArgList "make-vector" "integer" 1++lispVecFromArgs :: [LispVal] -> ThrowsError LispVal+lispVecFromArgs vals =+ return (Vector (toInteger (length vals)) (DIM.fromAscList (addkey 0 vals)))+ where addkey _ [] = []+ addkey n (v:vs) = (n, v):(addkey (n+1) vs)++lispListToVec :: [LispVal] -> ThrowsError LispVal+lispListToVec [List vals] =+ return (Vector (toInteger (length vals)) (DIM.fromAscList (addkey 0 vals)))+ where addkey _ [] = []+ addkey n (v:vs) = (n, v):(addkey (n+1) vs)+lispListToVec badArgList =+ genericBadArg badArgList "list->vector" "list" 1++lispVecToList :: [LispVal] -> ThrowsError LispVal+lispVecToList [Vector _ vec] =+ return (List (getval (DIM.toAscList vec)))+ where getval [] = []+ getval ((_,v):vs) = v:(getval vs)+lispVecToList badArgList =+ genericBadArg badArgList "vector->list" "vector" 1++lispVecSize :: [LispVal] -> ThrowsError LispVal+lispVecSize [Vector len _] = return (IntNumber len)+lispVecSize badArgList = genericBadArg badArgList "vector-length" "vector" 1++lispVecRef :: [LispVal] -> ThrowsError LispVal+lispVecRef [Vector len vec, IntNumber n] =+ if (n >= 0 && n < len)+ then return (DIM.findWithDefault (Bool False) (fromInteger n) vec)+ else throwError (VectorBounds len (IntNumber n))+lispVecRef badArgList =+ genericBadArg badArgList "vector-ref" "vector + integer" 2++getfn1 :: LispVal -> [LispVal] -> LispVal+getfn1 a b = List (Symbol "lambda" : a : b)++getfn :: [String] -> Maybe String -> [LispVal] -> LispVal+getfn ps Nothing body = getfn1 (List (map Symbol ps)) body+getfn [] (Just v) body = getfn1 (Symbol v) body+getfn ps (Just v) body = getfn1 (DottedList (map Symbol ps) (Symbol v)) body++proc2data :: [LispVal] -> ThrowsError LispVal+proc2data [Func pars var body _] = return (getfn pars var body)+proc2data [TraceFunc _ pars var body _] = return (getfn pars var body)+proc2data [Delay obj _ _] = return obj+proc2data [Prim _] =+ throwError (Default "procedure->data can't handle builtin functions")+proc2data [IOPrim _] =+ throwError (Default "procedure->data can't handle builtin functions")+proc2data badArgList =+ genericBadArg badArgList "procedure->data" "lisp function" 1++primitives :: [(String, [LispVal] -> ThrowsError LispVal)]+primitives = [("+", lispPlus),+ ("-", lispMinus),+ ("*", lispMul),+ ("/", lispDiv),+ ("expt", lispPow),+ ("min", lispMin),+ ("max", lispMax),+ ("modulo", integerBinop "modulo" mod),+ ("quotient", integerBinop "quotient" quot),+ ("remainder", integerBinop "remainder" rem),+ ("gcd", integerBinop "gcd" gcd),+ ("lcm", integerBinop "lcm" lcm),+ ("=", numBoolBinop "=" (==) (==) (==) False),+ ("<", numBoolBinop "<" (<) (<) (<) False),+ (">", numBoolBinop ">" (>) (>) (>) False),+ ("/=", numBoolBinop "/=" (/=) (/=) (/=) True),+ (">=", numBoolBinop ">=" (>=) (>=) (>=) False),+ ("<=", numBoolBinop "<=" (<=) (<=) (<=) False),+ ("boolean?", isBool),+ ("symbol?", Library.isSymbol),+ ("char?", isChar),+ ("number?", Library.isNumber),+ ("integer?", isInteger),+ ("rational?", isRational),+ ("real?", isReal),+ ("string?", isString),+ ("pair?", isPair),+ ("list?", isList),+ ("null?", isNull),+ ("port?", isPort),+ ("procedure?", isProcedure),+ ("vector?", isVector),+ ("even?", lispIsEven),+ ("odd?", lispIsOdd),+ ("zero?", isZero),+ ("positive?", isPositive),+ ("negative?", isNegative),+ ("nan?", lispIsNaN),+ ("infinite?", lispIsInf),+ ("finite?", lispIsFinite),+ ("not", lispNot),+ ("id", lispId),+ ("string=?", strBoolBinop "string=?" (==)),+ ("string<?", strBoolBinop "string<?" (<)),+ ("string>?", strBoolBinop "string>?" (>)),+ ("string>=?", strBoolBinop "string>=?" (>=)),+ ("string<=?", strBoolBinop "string<=?" (<=)),+ ("char=?", charBoolBinop "char=?" (==)),+ ("char<?", charBoolBinop "char<?" (<)),+ ("char>?", charBoolBinop "char>?" (>)),+ ("char>=?", charBoolBinop "char>=?" (>=)),+ ("char<=?", charBoolBinop "char<=?" (<=)),+ ("char->string", char2str),+ ("string->char", str2char),+ ("string->number", readNum),+ ("number->string", writeNum),+ ("symbol->string", symb2str),+ ("char-alphabetic?", charIs isAlpha),+ ("char-numeric?", charIs isDigit),+ ("char-oct-digit?", charIs isOctDigit),+ ("char-hex-digit?", charIs isHexDigit),+ ("char-whitespace?", charIs isSpace),+ ("char-upper-case?", charIs isUpper),+ ("char-lower-case?", charIs isLower),+ ("char-alphanumeric?", charIs isAlphaNum),+ ("char-control?", charIs isControl),+ ("char-printable?", charIs isPrint),+ ("char-upcase", charTo toUpper),+ ("char-downcase", charTo toLower),+ ("string-upcase", charTo toUpper),+ ("string-downcase", charTo toLower),+ ("car", car),+ ("cdr", cdr),+ ("cons", cons),+ ("eqv?", eqvFunc),+ ("char->integer", char2int),+ ("integer->char", int2char),+ ("floor", lispFloor),+ ("truncate", lispTruncate),+ ("round", lispRound),+ ("ceiling", lispCeiling),+ ("numerator", lispNumerator),+ ("denominator", lispDenominator),+ ("abs", lispAbs),+ ("sqrt", numericFunc "sqrt" sqrt),+ ("exp", numericFunc "exp" exp),+ ("log", numericFunc "log" log),+ ("sin", numericFunc "sin" sin),+ ("cos", numericFunc "cos" cos),+ ("tan", numericFunc "tan" tan),+ ("sinh", numericFunc "sinh" sinh),+ ("cosh", numericFunc "cosh" cosh),+ ("tanh", numericFunc "tanh" tanh),+ ("asin", numericFunc "asin" asin),+ ("acos", numericFunc "acos" acos),+ ("atan", lispATan2),+ ("asinh", numericFunc "asinh" asinh),+ ("acosh", numericFunc "acosh" acosh),+ ("atanh", numericFunc "atanh" atanh),+ ("list", lispListFromArgs),+ ("reverse", lispReverse),+ ("last", lispLast),+ ("length", lispLength),+ ("list-head", lispListHead),+ ("list-tail", lispListTail),+ ("list-ref", lispListRef),+ ("ilog", lispILog),+ ("factorial", lispFactorial),+ ("make-vector", lispMakeVector),+ ("vector", lispVecFromArgs),+ ("vector-length", lispVecSize),+ ("list->vector", lispListToVec),+ ("vector->list", lispVecToList),+ ("vector-ref", lispVecRef),+ ("procedure->data", proc2data)]++-- A bunch of library functions that do IO:+-- these get put into the ioPrimitives table below++-- This is the wrapper which catches IO errors... I dunno what type it is+-- This converts a system-level error into a lisp-level error by the+-- kinda-funky (Default (show err)), assuming we don't swallow the error++doIOAction action ctor epred =+ do ret <- liftIO (try action)+ case ret of+ Left err -> if epred err+ then throwError (Default (show err))+ else return (Bool False)+ Right val -> return (ctor val)++-- A couple of utility functions for using doIOAction: dropToBool is a+-- quasi-constructor which drops whatever it was handed, and instead only+-- returns Bool True; allErrs and noEOF are selectors for various errors:+-- generally we want to hear about errors, but EOF when reading a line or+-- character isn't really an error, so we silence that one.++dropToBool _ = Bool True+allErrs _ = True+noEOF err = not (isEOFError err)++makePort :: IOMode -> [LispVal] -> IOThrowsError LispVal+makePort mode [String filename] =+ doIOAction (openFile filename mode) Port allErrs+makePort _ badArgList = genericIOBadArg badArgList "open-IO-file" "string" 1++closePort :: [LispVal] -> IOThrowsError LispVal+closePort [Port port] =+ doIOAction (hClose port) dropToBool allErrs+closePort [Socket sock] =+ doIOAction (sClose sock) dropToBool allErrs+closePort _ = return (Bool False)++readLine :: [LispVal] -> IOThrowsError LispVal+readLine [] = readLine [Port stdin]+readLine [Port port] = doIOAction (hGetLine port) String noEOF+readLine badArgList = genericIOBadArg badArgList "read-line" "read port" 1++readChar :: [LispVal] -> IOThrowsError LispVal+readChar [] = readChar [Port stdin]+readChar [Port port] = doIOAction (hGetChar port) Char noEOF+readChar badArgList = genericIOBadArg badArgList "read-char" "read port" 1++displayProc :: [LispVal] -> IOThrowsError LispVal+displayProc [obj] = displayProc [obj, Port stdout]+displayProc [obj, Port port] =+ doIOAction (hPutStr port (show obj)) dropToBool allErrs+displayProc badArgList = genericIOBadArg badArgList "display" "write port" 2++readContents :: [LispVal] -> IOThrowsError LispVal+readContents [String filename] = doIOAction (readFile filename) String allErrs+readContents badArgList = genericIOBadArg badArgList "read-contents" "string" 1++loadFile :: String -> IOThrowsError [LispVal]+loadFile filename =+ do str <- doIOAction (readFile filename) String allErrs+ case str of+ Bool False -> throwError (Default "operation failed")+ String val -> liftThrows (readExprList val)++readAll :: [LispVal] -> IOThrowsError LispVal+readAll [String filename] = liftM List (loadFile filename)+readAll badArgList = genericIOBadArg badArgList "read-all" "string" 1++lispPutStr :: [LispVal] -> IOThrowsError LispVal+lispPutStr [] = return (Bool False)+lispPutStr ((Port port):rest) =+ mapM outStr rest >> return (Bool True)+ where outStr (String s) = doIOAction (hPutStr port s) dropToBool allErrs+ outStr (Char c) = doIOAction (hPutChar port c) dropToBool allErrs+ outStr notS = genericIOBadArg [notS] "write-string" "string" 1+lispPutStr (s:ss) = lispPutStr ((Port stdout):s:ss)++flushPort :: [LispVal] -> IOThrowsError LispVal+flushPort [] = flushPort [Port stdout]+flushPort [Port p] = doIOAction (hFlush p) dropToBool allErrs+flushPort badArgList = genericIOBadArg badArgList "flush-port" "port" 1++lispError :: [LispVal] -> IOThrowsError LispVal+lispError [] = throwError (UserException (List []))+lispError [val] = throwError (UserException val)+lispError info = throwError (UserException (List info))++lispExit :: [LispVal] -> IOThrowsError LispVal+lispExit [Bool False] = liftIO (exitWith (ExitFailure 1))+lispExit [Bool True] = liftIO (exitWith ExitSuccess)+lispExit [IntNumber n] | n == 0 = liftIO (exitWith ExitSuccess)+ | otherwise = liftIO(exitWith (ExitFailure+ (fromInteger n)))+lispExit [String s] = liftIO (hPutStrLn stderr s >> exitWith (ExitFailure 1))+lispExit _ = liftIO (hPutStrLn stderr "goodbye!" >> exitWith (ExitFailure 1))++lispFileExists :: [LispVal] -> IOThrowsError LispVal+lispFileExists [String filename] =+ doIOAction (doesFileExist filename) Bool allErrs+lispFileExists badArgList =+ genericIOBadArg badArgList "file-exists?" "string" 1++lispDirExists :: [LispVal] -> IOThrowsError LispVal+lispDirExists [String dirname] =+ doIOAction (doesDirectoryExist dirname) Bool allErrs+lispDirExists badArgList =+ genericIOBadArg badArgList "directory-exists?" "string" 1++lispRenameFile :: [LispVal] -> IOThrowsError LispVal+lispRenameFile [String oldname, String newname] =+ doIOAction (renameFile oldname newname) dropToBool allErrs+lispRenameFile badArgList = genericIOBadArg badArgList "rename-file" "string" 2++lispCreateLink :: [LispVal] -> IOThrowsError LispVal+lispCreateLink [String oldname, String newname] =+ doIOAction (createLink oldname newname) dropToBool allErrs+lispCreateLink badArgList = genericIOBadArg badArgList "create-link" "string" 2++lispCreateSymbolicLink :: [LispVal] -> IOThrowsError LispVal+lispCreateSymbolicLink [String oldname, String newname] =+ doIOAction (createSymbolicLink oldname newname) dropToBool allErrs+lispCreateSymbolicLink badArgList =+ genericIOBadArg badArgList "create-symbolic-link" "string" 2++lispRemoveFile :: [LispVal] -> IOThrowsError LispVal+lispRemoveFile [String filename] =+ doIOAction (removeFile filename) dropToBool allErrs+lispRemoveFile badArgList = genericIOBadArg badArgList "remove-file" "string" 2++lispCreateDir :: [LispVal] -> IOThrowsError LispVal+lispCreateDir [String dirname] =+ doIOAction (createDirectory dirname) dropToBool allErrs+lispCreateDir badArgList =+ genericIOBadArg badArgList "create-directory" "string" 1++lispRemoveDir :: [LispVal] -> IOThrowsError LispVal+lispRemoveDir [String dirname] =+ doIOAction (removeDirectory dirname) dropToBool allErrs+lispRemoveDir badArgList =+ genericIOBadArg badArgList "remove-directory" "string" 1++lispRenameDir :: [LispVal] -> IOThrowsError LispVal+lispRenameDir [String oldname, String newname] =+ doIOAction (renameDirectory oldname newname) dropToBool allErrs+lispRenameDir badArgList =+ genericIOBadArg badArgList "rename-directory" "string" 2++lispSetCurrentDir :: [LispVal] -> IOThrowsError LispVal+lispSetCurrentDir [String dirname] =+ doIOAction (setCurrentDirectory dirname) dropToBool allErrs+lispSetCurrentDir badArgList =+ genericIOBadArg badArgList "set-current-directory" "nothing" 0++lispGetCurrentDir :: [LispVal] -> IOThrowsError LispVal+lispGetCurrentDir [] =+ doIOAction (getCurrentDirectory) String allErrs+lispGetCurrentDir badArgList =+ genericIOBadArg badArgList "get-current-directory" "nothing" 0++lispGetDirContents :: [LispVal] -> IOThrowsError LispVal+lispGetDirContents [String dirname] =+ doIOAction (getDirectoryContents dirname) loS allErrs+ where loS arr = List (toS arr)+ toS [] = []+ toS (str:strs) = (String str):(toS strs)++lispGetDirContents badArgList =+ genericIOBadArg badArgList "read-directory" "string" 1++lispGetEnv :: [LispVal] -> IOThrowsError LispVal+lispGetEnv [] =+ doIOAction (getEnvironment) loSS allErrs+ where loSS arr = List (toSS arr)+ toSS [] = []+ toSS ((key,val):strs) =+ (DottedList [String key] (String val)):(toSS strs)+lispGetEnv [String key] =+ doIOAction (getEnvDefault key "") String allErrs+lispGetEnv badArgList =+ genericIOBadArg badArgList "get-environment" "string" 1++lispSetEnv :: [LispVal] -> IOThrowsError LispVal+lispSetEnv [String key, String val] =+ doIOAction (putEnv (key ++ "=" ++ val)) dropToBool allErrs+lispSetEnv badArgList =+ genericIOBadArg badArgList "set-environment" "string" 2++lispUnSetEnv :: [LispVal] -> IOThrowsError LispVal+lispUnSetEnv [String key] = doIOAction (unsetEnv key) dropToBool allErrs+lispUnSetEnv badArgList =+ genericIOBadArg badArgList "unset-environment" "string" 1+++lispEpochTime :: [LispVal] -> IOThrowsError LispVal+lispEpochTime [] = doIOAction (getClockTime) getET allErrs+ where getET (TOD sec psec) =+ FltNumber ((fromInteger sec) + 1.0e-12*(fromInteger psec))+lispEpochTime badArgList = genericIOBadArg badArgList "epochtime" "nothing" 0++lispLocalTime :: [LispVal] -> IOThrowsError LispVal+lispLocalTime [] = doIOAction (getClockTime) toS allErrs+ where toS val = String (show val)+lispLocalTime [IntNumber n] =+ doIOAction (toCalendarTime (TOD n 0)) toS allErrs+ where toS val = String (calendarTimeToString val)+lispLocalTime [RatNumber n] =+ doIOAction (toCalendarTime (TOD (round n) 0)) toS allErrs+ where toS val = String (calendarTimeToString val)+lispLocalTime [FltNumber n] =+ doIOAction (toCalendarTime (TOD (round n) 0)) toS allErrs+ where toS val = String (calendarTimeToString val)+lispLocalTime badArgList = genericIOBadArg badArgList "localtime" "nothing" 0++lispUTCTime :: [LispVal] -> IOThrowsError LispVal+lispUTCTime [] = doIOAction (getClockTime) toS allErrs+ where toS val = String (calendarTimeToString (toUTCTime val))+lispUTCTime [IntNumber n] =+ return (String (calendarTimeToString (toUTCTime (TOD n 0))))+lispUTCTime [RatNumber n] =+ return (String (calendarTimeToString (toUTCTime (TOD (round n) 0))))+lispUTCTime [FltNumber n] =+ return (String (calendarTimeToString (toUTCTime (TOD (round n) 0))))+lispUTCTime badArgList = genericIOBadArg badArgList "UTCtime" "nothing" 0++lispGetCPUTime :: [LispVal] -> IOThrowsError LispVal+lispGetCPUTime [] =+ doIOAction (getCPUTime) toS allErrs+ where toS val = FltNumber ((fromInteger val)/1.0e12)+lispGetCPUTime badArgList =+ genericIOBadArg badArgList "cputime" "nothing" 0++statData :: FileStatus -> LispVal+statData stat =+ List [IntNumber (read (show (deviceID stat))),+ IntNumber (toInteger (fileID stat)),+ IntNumber (toInteger (fileMode stat)),+ IntNumber (toInteger (linkCount stat)),+ IntNumber (toInteger (fileOwner stat)),+ IntNumber (toInteger (fileGroup stat)),+ IntNumber (read (show (specialDeviceID stat))),+ IntNumber (toInteger (fileSize stat)),+ getET (accessTime stat),+ getET (modificationTime stat),+ getET (statusChangeTime stat)]+ where getET t = FltNumber (realToFrac t)++lispGetFileStatus :: [LispVal] -> IOThrowsError LispVal+lispGetFileStatus [String filename] =+ doIOAction (getFileStatus filename) statData allErrs+lispGetFileStatus badArgList =+ genericIOBadArg badArgList "get-file-status" "string" 1++lispGetLinkStatus :: [LispVal] -> IOThrowsError LispVal+lispGetLinkStatus [String filename] =+ doIOAction (getSymbolicLinkStatus filename) statData allErrs+lispGetLinkStatus badArgList =+ genericIOBadArg badArgList "get-link-status" "string" 1++lispIsBlockDevice :: [LispVal] -> IOThrowsError LispVal+lispIsBlockDevice [String filename] =+ doIOAction (getFileStatus filename) (Bool . isBlockDevice) allErrs+lispIsBlockDevice badArgList =+ genericIOBadArg badArgList "is-block-device?" "string" 1++lispIsCharacterDevice :: [LispVal] -> IOThrowsError LispVal+lispIsCharacterDevice [String filename] =+ doIOAction (getFileStatus filename) (Bool . isCharacterDevice) allErrs+lispIsCharacterDevice badArgList =+ genericIOBadArg badArgList "is-char-device?" "string" 1++lispIsNamedPipe :: [LispVal] -> IOThrowsError LispVal+lispIsNamedPipe [String filename] =+ doIOAction (getFileStatus filename) (Bool . isNamedPipe) allErrs+lispIsNamedPipe badArgList =+ genericIOBadArg badArgList "is-named-pipe?" "string" 1++lispIsRegularFile :: [LispVal] -> IOThrowsError LispVal+lispIsRegularFile [String filename] =+ doIOAction (getFileStatus filename) (Bool . isRegularFile) allErrs+lispIsRegularFile badArgList =+ genericIOBadArg badArgList "is-regular-file?" "string" 1++lispIsDirectory :: [LispVal] -> IOThrowsError LispVal+lispIsDirectory [String filename] =+ doIOAction (getFileStatus filename) (Bool . isDirectory) allErrs+lispIsDirectory badArgList =+ genericIOBadArg badArgList "is-directory?" "string" 1++lispIsSymbolicLink :: [LispVal] -> IOThrowsError LispVal+lispIsSymbolicLink [String filename] =+ doIOAction (getFileStatus filename) (Bool . isSymbolicLink) allErrs+lispIsSymbolicLink badArgList =+ genericIOBadArg badArgList "is-symbolic-link?" "string" 1++lispIsSocket :: [LispVal] -> IOThrowsError LispVal+lispIsSocket [String filename] =+ doIOAction (getFileStatus filename) (Bool . isSocket) allErrs+lispIsSocket badArgList =+ genericIOBadArg badArgList "is-socket?" "string" 1++lispRandUni :: [LispVal] -> IOThrowsError LispVal+lispRandUni [] =+ doIOAction (getStdRandom (randomR (0 :: Double, 1))) FltNumber allErrs+lispRandUni [IntNumber lo, IntNumber hi] =+ if lo < hi+ then doIOAction (getStdRandom (randomR (lo, hi))) IntNumber allErrs+ else doIOAction (getStdRandom (randomR (hi, lo))) IntNumber allErrs+lispRandUni [FltNumber lo, FltNumber hi] =+ if lo < hi+ then doIOAction (getStdRandom (randomR (lo, hi))) FltNumber allErrs+ else doIOAction (getStdRandom (randomR (hi, lo))) FltNumber allErrs+lispRandUni badArgList =+ genericIOBadArg badArgList "random-uniform" "two numbers" 2++lispRandExp :: [LispVal] -> IOThrowsError LispVal+lispRandExp [FltNumber m] =+ if m > 0+ then getrand >>= return . FltNumber . (sc m) . negate . log+ else genericIOBadArg [FltNumber m] "random-exponential" "positive rate" 1+ where getrand =+ do val <- lispRandUni []+ if getnum val == 0+ then getrand+ else return (getnum val)+ getnum (FltNumber n) = n+ sc s v = v/s+lispRandExp [] = lispRandExp [FltNumber 1.0]+lispRandExp [IntNumber m] = lispRandExp [FltNumber (fromInteger m)]+lispRandExp [RatNumber m] = lispRandExp [FltNumber (fromRational m)]+lispRandExp badArgList =+ genericIOBadArg badArgList "random-exponential" "number" 1++lispRandNorm :: [LispVal] -> IOThrowsError LispVal+lispRandNorm [FltNumber m, FltNumber s] =+ if s > 0+ then do x1 <- getrand+ x2 <- getrand+ let a = s*sqrt (-2.0*(log x1))+ b = 2.0*pi*x2+ y1 = m + a*(cos b)+ y2 = m + a*(sin b)+ return (List [FltNumber y1, FltNumber y2])+ else throwError (Default ("random-normal-pair needs a positive stddev,"+ ++ " got " ++ (show s)))+ where getrand =+ do val <- lispRandUni []+ if getnum val == 0+ then getrand+ else return (getnum val)+ getnum (FltNumber n) = n+lispRandNorm [] = lispRandNorm [FltNumber 0.0, FltNumber 1.0]+lispRandNorm [IntNumber m, IntNumber s] =+ lispRandNorm [FltNumber (fromInteger m), FltNumber (fromInteger s)]+lispRandNorm [IntNumber m, RatNumber s] =+ lispRandNorm [FltNumber (fromInteger m), FltNumber (fromRational s)]+lispRandNorm [IntNumber m, FltNumber s] =+ lispRandNorm [FltNumber (fromInteger m), FltNumber s]+lispRandNorm [RatNumber m, IntNumber s] =+ lispRandNorm [FltNumber (fromRational m), FltNumber (fromInteger s)]+lispRandNorm [RatNumber m, RatNumber s] =+ lispRandNorm [FltNumber (fromRational m), FltNumber (fromRational s)]+lispRandNorm [RatNumber m, FltNumber s] =+ lispRandNorm [FltNumber (fromRational m), FltNumber s]+lispRandNorm [FltNumber m, IntNumber s] =+ lispRandNorm [FltNumber m, FltNumber (fromInteger s)]+lispRandNorm [FltNumber m, RatNumber s] =+ lispRandNorm [FltNumber m, FltNumber (fromRational s)]+lispRandNorm badArgList =+ genericIOBadArg badArgList "random-normal-pair" "number" 2++-- TODO: for large lambda, this will be slow! Fix!++lispRandPoisson :: [LispVal] -> IOThrowsError LispVal+lispRandPoisson [FltNumber lambda] =+ if lambda > 0+ then do val <- doit (exp (-lambda)) (-1) (1 :: Double)+ return (IntNumber val)+ else throwError (Default ("random-poisson needs a positive lambda,"+ ++ " got " ++ (show lambda)))+ where doit l k p =+ do r <- lispRandUni []+ let pp = p*(getnum r)+ kp = k + 1+ if pp < l+ then return kp+ else doit l kp pp+ getnum (FltNumber n) = n+lispRandPoisson [IntNumber m] = lispRandPoisson [FltNumber (fromInteger m)]+lispRandPoisson [RatNumber m] = lispRandPoisson [FltNumber (fromRational m)]++lispSeedRandom :: [LispVal] -> IOThrowsError LispVal+lispSeedRandom [IntNumber n] =+ doIOAction (setStdGen (mkStdGen (fromInteger n))) dropToBool allErrs+lispSeedRandom [String s] =+ doIOAction (setStdGen (read s)) dropToBool allErrs+lispSeedRandom badArgList =+ genericIOBadArg badArgList "random-seed!" "integer or string" 1++lispConnectTo :: [LispVal] -> IOThrowsError LispVal+lispConnectTo [String hostname, IntNumber port] =+ doIOAction (connectTo hostname (PortNumber (fromInteger port))) Port allErrs+lispConnectTo [String hostname, String usock] =+ doIOAction (connectTo hostname (UnixSocket usock)) Port allErrs+lispConnectTo badArgList =+ genericIOBadArg badArgList "connect-to" "host port" 2++lispListenOn :: [LispVal] -> IOThrowsError LispVal+lispListenOn [IntNumber port] =+ doIOAction (listenOn (PortNumber (fromInteger port))) Socket allErrs+lispListenOn [String usock] =+ doIOAction (listenOn (UnixSocket usock)) Socket allErrs+lispListenOn badArgList =+ genericIOBadArg badArgList "listen-on" "port" 1++lispAccept :: [LispVal] -> IOThrowsError LispVal+lispAccept [Socket s] =+ do ret <- liftIO (try (accept s))+ case ret of+ Left err -> throwError (Default (show err))+ Right val -> return (List [Port (val1 val),+ String (val2 val),+ IntNumber (toInteger (val3 val))])+ where val1 (a,_,_) = a+ val2 (_,b,_) = b+ val3 (_,_,c) = c+lispAccept badArgList =+ genericIOBadArg badArgList "accept" "socket" 1++lispSetLineBuf :: [LispVal] -> IOThrowsError LispVal+lispSetLineBuf [Port h] =+ doIOAction (hSetBuffering h LineBuffering) dropToBool allErrs+lispSetLineBuf badArgList =+ genericIOBadArg badArgList "set-line-buffering!" "port" 1++lispSetNoBuf :: [LispVal] -> IOThrowsError LispVal+lispSetNoBuf [Port h] =+ doIOAction (hSetBuffering h NoBuffering) dropToBool allErrs+lispSetNoBuf badArgList =+ genericIOBadArg badArgList "set-no-buffering!" "port" 1++ioPrimitives :: [(String, [LispVal] -> IOThrowsError LispVal)]+ioPrimitives = [("open-input-file", makePort ReadMode),+ ("open-output-file", makePort WriteMode),+ ("open-append-file", makePort AppendMode),+ ("rename-file", lispRenameFile),+ ("remove-file", lispRemoveFile),+ ("create-link", lispCreateLink),+ ("create-symbolic-link", lispCreateSymbolicLink),+ ("close-port", closePort),+ ("raise", lispError),+ ("display", displayProc),+ ("read-line", readLine),+ ("read-char", readChar),+ ("read-contents", readContents),+ ("read-all", readAll),+ ("write-string", lispPutStr),+ ("flush-port", flushPort),+ ("exit", lispExit),+ ("get-current-directory", lispGetCurrentDir),+ ("set-current-directory", lispSetCurrentDir),+ ("create-directory", lispCreateDir),+ ("remove-directory", lispRemoveDir),+ ("rename-directory", lispRenameDir),+ ("read-directory", lispGetDirContents),+ ("file-exists?", lispFileExists),+ ("directory-exists?", lispDirExists),+ ("get-environment", lispGetEnv),+ ("set-environment", lispSetEnv),+ ("unset-environment", lispUnSetEnv),+ ("epochtime", lispEpochTime),+ ("localtime", lispLocalTime),+ ("UTCtime", lispUTCTime),+ ("cputime", lispGetCPUTime),+ ("get-file-status", lispGetFileStatus),+ ("get-link-status", lispGetLinkStatus),+ ("is-block-device?", lispIsBlockDevice),+ ("is-char-device?", lispIsCharacterDevice),+ ("is-named-pipe?", lispIsNamedPipe),+ ("is-regular-file?", lispIsRegularFile),+ ("is-directory?", lispIsDirectory),+ ("is-symbolic-link?", lispIsSymbolicLink),+ ("is-socket?", lispIsSocket),+ ("random-uniform", lispRandUni),+ ("random-exponential", lispRandExp),+ ("random-normal-pair", lispRandNorm),+ ("random-poisson", lispRandPoisson),+ ("random-seed!", lispSeedRandom),+ ("set-line-buffering!", lispSetLineBuf),+ ("set-no-buffering!", lispSetNoBuf),+ ("connect-to", lispConnectTo),+ ("listen-on", lispListenOn),+ ("accept", lispAccept)]++-- A couple of predefined data values++ioPorts :: [(String, LispVal)]+ioPorts = [("stdin", (Port stdin)),+ ("stdout", (Port stdout)),+ ("stderr", (Port stderr)),+ ("pi", (FltNumber pi))]++-- And finally some stuff for internal work++-- delayCounter is the name under which a counter for delay objects+-- is stored in the environment. It contains spaces, so that it is+-- impossible for the user to enter this as a valid symbol. Ditto+-- for symbolCounter: this is for generating new internal symbols.++delayCounter :: String+delayCounter = " delay "++symbolCounter :: String+symbolCounter = " symbol "++internals :: [(String, LispVal)]+internals = [(delayCounter, (IntNumber 0)),+ (symbolCounter, (IntNumber 0))]++primitiveBindings :: IO Env+primitiveBindings = newIORef [] >>=+ (flip bindVars (internals ++ map (mkf IOPrim) ioPrimitives +++ map (mkf Prim) primitives ++ ioPorts))+ where mkf constructor (var, func) = (var, constructor func)
+ LispData.hs view
@@ -0,0 +1,189 @@+{- Copyright 2008 Uwe Hollerbach <uh@alumni.caltech.edu>+Portions of this were derived from Jonathan Tang's haskell+tutorial "Write yourself a scheme in 48 hours" and are thus+Copyright Jonathan Tang+(but I can't easily tell anymore who originally wrote what)++This file is part of haskeem.+haskeem is free software; you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation; either version 2 of the License, or+(at your option) any later version.++haskeem is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+GNU General Public License for more details.++You should have received a copy of the GNU General Public License+along with haskeem; if not, write to the Free Software+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA++$Id: lispdata.hs,v 1.11 2009-05-31 01:41:08 uwe Exp $ -}++module LispData+ (LispVal(Symbol, Bool, Char, Delay, DottedList, IntNumber, RatNumber,+ FltNumber, Func, IOPrim, List, Port, Prim, Socket, String,+ TraceFunc, Vector),+ LispError(NumArgs, TypeMismatch, Parser, BadSpecial, NotFunction,+ UnboundVar, Default, OutOfRange, VectorBounds, UserException),+ ThrowsError, Env, IOThrowsError, liftThrows,+ myRatPInf, myRatNInf, myRatNaN, myFltPInf, myFltNInf, myFltNaN) where+import Prelude+import IO hiding (try)+import Data.Char+import Data.Ratio()+import Text.ParserCombinators.Parsec as TPCP hiding (spaces)+import Control.Monad.Error as CME+import Data.IORef+import qualified Data.IntMap as DIM+import GHC.Real -- for the :% operator, which does not reduce the fractions+import Network++-- Define everything we are going to work with, and how to display it++-- rational infinities and NaN: gotta take care with these,+-- they don't always play nice with other numbers++myRatPInf, myRatNInf, myRatNaN :: Rational+myRatPInf = 1:%0+myRatNInf = (-1):%0+myRatNaN = 0:%0++-- floating-point infinities and NaN++myFltPInf, myFltNInf, myFltNaN :: Double+myFltPInf = (1.0e99 ** 1.0e99) -- probably big enough...+myFltNInf = (-myFltPInf)+myFltNaN = sqrt (-1.0)++-- An environment: a table connecting names of objects and values++type Env = IORef [(String, IORef LispVal)]++-- A lisp value: these are the stuff which normally gets processed++data LispVal = Symbol String+ | Bool Bool+ | IntNumber Integer+ | RatNumber Rational+ | FltNumber Double+ | String String+ | List [LispVal]+ | DottedList [LispVal] LispVal+ | Char Char+ | Prim ([LispVal] -> ThrowsError LispVal)+ | Func {params :: [String],+ vararg :: (Maybe String),+ body :: [LispVal],+ closure :: Env}+ | TraceFunc {name :: String,+ params :: [String],+ vararg :: (Maybe String),+ body :: [LispVal],+ closure :: Env}+ | Delay {obj :: LispVal,+ closure :: Env,+ tag :: String}+ | IOPrim ([LispVal] -> IOThrowsError LispVal)+ | Port Handle+ | Socket Socket+ | Vector Integer (DIM.IntMap LispVal)++instance Show LispVal where show = showVal++showVal :: LispVal -> String+showVal (Symbol atom) = atom+showVal (Bool True) = "#t"+showVal (Bool False) = "#f"+showVal (IntNumber num) = show num+showVal (RatNumber num) =+ (show (numerator num)) ++ "/" ++ (show (denominator num))+showVal (FltNumber num) = show num+showVal (String str) = "\"" ++ str ++ "\""+showVal (List lst) = "(" ++ (unwords (map showVal lst)) ++ ")"+showVal (DottedList lst cab) = "(" ++ (unwords (map showVal lst))+ ++ " . " ++ (showVal cab) ++ ")"+-- the control-character printing and parsing assumes ASCII+showVal (Char ch) | (ch == (chr 0)) = "#\\nul"+ | (ch == (chr 7)) = "#\\alarm"+ | (ch == (chr 8)) = "#\\backspace"+ | (ch == '\t') = "#\\tab"+ | (ch == '\n') = "#\\linefeed"+ | (ch == (chr 11)) = "#\\vtab"+ | (ch == (chr 12)) = "#\\page"+ | (ch == '\r') = "#\\return"+ | (ch == (chr 27)) = "#\\esc"+ | (ch == ' ') = "#\\space"+ | (ch == (chr 127)) = "#\\delete"+ | isControl ch = "#\\^" ++ [chr (ord ch + ord 'A' - 1)]+ | isPrint ch = "#\\" ++ [ch]+ | otherwise = [ch]+showVal (Prim _) = "<primitive>"+showVal (Func {params = args, vararg = varargs, body = _, closure = _}) =+ "(lambda (" ++ (unwords args) +++ (case varargs of+ Nothing -> ""+ Just arg -> " . " ++ arg) ++ ") ...)"+showVal (IOPrim _) = "<IO primitive>"+showVal (Port _) = "<IO port>"+showVal (Socket _) = "<IO socket>"+showVal (TraceFunc {name = nm, params = args, vararg = varargs,+ body = bd, closure = _}) =+ "(" ++ nm ++ " . (lambda (" ++ (unwords args) +++ (case varargs of+ Nothing -> ""+ Just arg -> " . " ++ arg) ++ ") " +++ (unwords (map showVal bd)) ++ "))"++showVal (Delay {obj = o, closure = _, tag = _}) =+ "<promise>" ++ (show o)++showVal (Vector _ vals) =+ "#(" ++ (unwords (map showVal (DIM.elems vals))) ++ ")"++-- A lisp error: these get processed when an error of some kind occurs++data LispError = NumArgs String Integer [LispVal]+ | TypeMismatch String String LispVal+ | Parser ParseError+ | BadSpecial String LispVal+ | NotFunction String LispVal+ | UnboundVar String String+ | Default String+ | OutOfRange String Double+ | VectorBounds Integer LispVal+ | UserException LispVal++instance Show LispError where show = showError++instance Error LispError where+ noMsg = Default "An error has occurred"+ strMsg = Default++showError :: LispError -> String+showError (NumArgs func expected found) =+ func ++ " expected " ++ show expected ++ " args; got values \"" +++ (unwords (map showVal found)) ++ "\""+showError (TypeMismatch func expected found) =+ func ++ " expected " ++ expected ++ " args; got " ++ (show found)+showError (Parser parseErr) = "Parse error at " ++ (show parseErr)+showError (BadSpecial msg form) = msg ++ ": \"" ++ (show form) ++ "\""+showError (NotFunction msg func) = msg ++ ": " ++ (show func)+showError (UnboundVar msg var) = msg ++ ": " ++ var+showError (Default msg) = msg+showError (OutOfRange func val) = func ++ " arg out of range: " ++ (show val)+showError (VectorBounds len n) =+ "vector index out of bounds: " ++ (show n) +++ " not in [0.." ++ (show (len - 1)) ++ "]"+showError (UserException val) = "user exception " ++ (show val)++type ThrowsError = Either LispError++type IOThrowsError = ErrorT LispError IO++-- convert a ThrowsError foo value into an IOThrowsError foo value++liftThrows :: ThrowsError a -> IOThrowsError a+liftThrows (Left err) = throwError err+liftThrows (Right val) = return val
+ Parser.hs view
@@ -0,0 +1,414 @@+{- Copyright 2008 Uwe Hollerbach <uh@alumni.caltech.edu>+Portions of this were derived from Jonathan Tang's haskell+tutorial "Write yourself a scheme in 48 hours" and are thus+Copyright Jonathan Tang+(but I can't easily tell anymore who originally wrote what)++This file is part of haskeem.+haskeem is free software; you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation; either version 2 of the License, or+(at your option) any later version.++haskeem is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+GNU General Public License for more details.++You should have received a copy of the GNU General Public License+along with haskeem; if not, write to the Free Software+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA++$Id: parser.hs,v 1.13 2009-05-31 01:41:08 uwe Exp $ -}++module Parser (readExpr, readExprList, readNumber) where+import Prelude+import Data.Char+import Data.Ratio+import Text.ParserCombinators.Parsec as TPCP hiding (spaces)+import Control.Monad.Error as CME+import qualified Data.IntMap as DIM++import LispData++-- Parsers for the various kinds of LispVal++-- "#!/some/path/to/executable" at the top of the file, to enable+-- scheme "shell" scripts: for the rest of the program, it's a comment++hashbang :: Parser Char+hashbang =+ do char '#'+ char '!'+ many (noneOf "\r\n")+ return ' '++-- semicolon to end-of-line, the oldest style of lisp comment++comment :: Parser Char+comment = + do char ';'+ many (noneOf "\r\n")+ return ' '++spaces :: Parser ()+spaces = skipMany1 (comment <|> space)++-- This is not quite R6RS-compliant: R6RS allows '.'++symbol :: Parser Char+symbol = oneOf "!$%&*+-/:<=>?@^_~"++-- This is a small extension to R6RS++controlChar :: Parser Char+controlChar =+ do char '^'+ c <- oneOf (['A' .. 'Z'] ++ "[\\]^_")+ return (chr (ord c + 1 - ord 'A'))++namedChar :: Parser Char+namedChar =+ do name <- (string "alarm"+ <|> string "backspace"+ <|> string "delete"+ <|> string "esc"+ <|> string "linefeed"+ <|> (TPCP.try (string "newline"))+ <|> string "nul"+ <|> string "page"+ <|> string "return"+ <|> string "space"+ <|> string "tab"+ <|> string "vtab")+ case name of+ "nul" -> return (chr 0)+ "alarm" -> return (chr 7)+ "backspace" -> return (chr 8)+ "tab" -> return '\t'+ "linefeed" -> return '\n'+ "newline" -> return '\n'+ "vtab" -> return (chr 11)+ "page" -> return (chr 12)+ "return" -> return '\r'+ "esc" -> return (chr 27)+ "space" -> return ' '+ "delete" -> return (chr 127)++parseChar :: Parser LispVal+parseChar =+ do char '#'+ char '\\'+ c <- (TPCP.try controlChar) <|> (TPCP.try namedChar) <|> anyChar+ return (Char c)++-- This is not quite R6RS-compliant: R6RS requires a hex escape spec,+-- and it forbids the "otherwise" clause below. oh well... later maybe++escChar :: Parser Char+escChar =+ do char '\\'+ c <- anyChar+ return (case c of+ 'a' -> chr 7+ 'b' -> chr 8+ 't' -> '\t'+ 'n' -> '\n'+ 'v' -> chr 11+ 'f' -> chr 12+ 'r' -> '\r'+ _ -> c)++parseBool :: Parser LispVal+parseBool =+ do char '#'+ v <- oneOf "tTfF"+ return (case v of+ 't' -> Bool True+ 'T' -> Bool True+ 'f' -> Bool False+ 'F' -> Bool False)++parseString :: Parser LispVal+parseString =+ do char '"'+ x <- many (escChar <|> (noneOf "\""))+ char '"'+ return (String x)++parseSymbol :: Parser LispVal+parseSymbol =+ do first <- letter <|> symbol+ rest <- many (letter <|> digit <|> symbol)+ return (Symbol (first:rest))++readBaseInt :: Integer -> String -> Integer+readBaseInt b s = foldl ma 0 s+ where ma v1 v2 = b*v1 + (toInteger (digitToInt v2))++readBaseFrac :: Integer -> String -> Double+readBaseFrac _ [] = 0.0+readBaseFrac b s = r * foldr ma 0 s where+ r = 1.0/(fromInteger b)+ ma v1 v2 = fromIntegral (digitToInt v1) + r*v2++parseHdr :: Parser (Char, Integer)+parseHdr =+ do b <- option 'd' (char '#' >> oneOf "bodxBODX")+ s <- option '+' (oneOf "+-")+ let base = (case b of+ 'b' -> 2+ 'B' -> 2+ 'o' -> 8+ 'O' -> 8+ 'd' -> 10+ 'D' -> 10+ 'x' -> 16+ 'X' -> 16)+ return (s, base)++baseDigits :: Integer -> String+baseDigits 2 = "01"+baseDigits 8 = "01234567"+baseDigits 10 = "0123456789"+baseDigits 16 = "0123456789abcdefABCDEF"++int :: String+int = "int"++-- The fact that this parser can deal with floating-point numbers+-- in bases 2, 8, and 16 as well as 10 is an extension of R6RS.++-- Parse first alternative for floating-point numbers: \d+(\.\d*)?++parseF1 :: Integer -> Parser (String,String)+parseF1 b =+ do ip <- many1 (oneOf (baseDigits b))+ fp <- option int (char '.' >> many (oneOf (baseDigits b)))+ return (ip,fp)++-- Parse second alternative for floating-point numbers: \.\d+++parseF2 :: Integer -> Parser (String,String)+parseF2 b =+ do char '.'+ fp <- many1 (oneOf (baseDigits b))+ return ("0",fp)++-- Parse the exponent++parseExp :: Integer -> Parser Integer+parseExp b =+ do if b == 16 then (oneOf "xX") else (oneOf "eExX")+ s <- option '+' (oneOf "+-")+ num <- many1 (oneOf (baseDigits b))+ let e = readBaseInt b num+ return (if s == '-' then (-e) else e)++powi :: Integer -> Integer -> Integer+powi b e | e == 0 = 1+ | e < 0 = error "negative exponent in powi"+ | even e = powi (b*b) (e `quot` 2)+ | otherwise = b * (powi b (e - 1))++pow :: Integer -> Integer -> Double+pow b e =+ if e >= 0 then fromInteger (powi b e) else recip (fromInteger (powi b (-e)))++-- Parse an integer or a floating-point number. This parser will return+-- numbers written as aaaEbb (with no decimal point) as integers, if the+-- exponent bb is non-negative.++parseIntOrFlt :: Parser LispVal+parseIntOrFlt =+ do (s, b) <- parseHdr+ (ip, fp) <- (parseF1 b) <|> (parseF2 b)+ e <- option 0 (parseExp b)+ let fpi = if fp == int then "0" else fp+ vf = (pow b e) * (fromInteger (readBaseInt b ip) + readBaseFrac b fpi)+ vi = (powi b e) * (readBaseInt b ip)+ if (fp == int && e >= 0)+ then return (IntNumber (if s == '-' then (-vi) else vi))+ else return (FltNumber (if s == '-' then (-vf) else vf))++-- Parse a rational number written as numerator/denominator. This parser+-- accepts and understands rational infinity, both positive and negative,+-- and rational not-a-number: +infinity is written as 1/0, -infinity as+-- -1/0, and not-a-number as 0/0. That's an incompatible extension of R6RS.++parseRat :: Parser LispVal+parseRat =+ do (s, b) <- parseHdr+ nstr <- many1 (oneOf (baseDigits b))+ char '/'+ dstr <- many1 (oneOf (baseDigits b))+ let num = readBaseInt b nstr+ den = readBaseInt b dstr+ ns = if s == '-' then (-num) else num+ val = if den /= 0+ then ns % den+ else if ns > 0+ then myRatPInf+ else if ns < 0+ then myRatNInf+ else myRatNaN+ if (denominator val) == 1+ then return (IntNumber (numerator val))+ else return (RatNumber val)++-- Parse a couple of special floating-point numbers mandated by R6RS++parseNaNInf :: Parser LispVal+parseNaNInf =+ do val <- (TPCP.try (string "+nan.0"))+ <|> (TPCP.try (string "-nan.0"))+ <|> (TPCP.try (string "+inf.0"))+ <|> (TPCP.try (string "-inf.0"))+ case val of+ "+nan.0" -> return (FltNumber myFltNaN)+ "-nan.0" -> return (FltNumber myFltNaN)+ "+inf.0" -> return (FltNumber myFltPInf)+ "-inf.0" -> return (FltNumber myFltNInf)++parseNumber :: Parser LispVal+parseNumber = (TPCP.try parseNaNInf) <|> (TPCP.try parseRat) <|> parseIntOrFlt++-- Parsers for the abbreviations for the various kinds of quoting entities:+-- '<datum> => (quote <datum>)+-- `<datum> => (quasiquote <datum>)+-- ,<datum> => (unquote <datum>)+-- ,@<datum> => (unquote-splicing <datum>)++parseQQ :: Parser LispVal+parseQQ =+ do char '`'+ x <- parseExpr+ return (List [Symbol "quasiquote", x])++parseQ :: Parser LispVal+parseQ =+ do char '\''+ x <- parseExpr+ return (List [Symbol "quote", x])++parseUQ :: Parser LispVal+parseUQ =+ do char ','+ x <- parseExpr+ return (List [Symbol "unquote", x])++parseUQS :: Parser LispVal+parseUQS =+ do char ','+ char '@'+ x <- parseExpr+ return (List [Symbol "unquote-splicing", x])++parseQuoted :: Parser LispVal+parseQuoted = (TPCP.try parseUQS)+ <|> (TPCP.try parseUQ)+ <|> (TPCP.try parseQQ)+ <|> parseQ++-- Parser for a dotted-list or a regular list. Due to the representation of+-- scheme lists as haskell lists rather than as dotted-pairs, it's slightly+-- tricky to get the case of (a . (b . (c . ()))) and similar forms to come+-- out right; however, that is explicitly described as exactly identical to+-- the list (a b c) according to the RnRS standard, so it has to be treated+-- correctly.++parseDottedList :: Parser LispVal+parseDottedList =+ do char '('+ skipMany space+ hd <- sepEndBy parseExpr spaces+ tl <- option (List []) (TPCP.try (char '.' >> spaces >> parseExpr))+ skipMany space+ char ')'+ if isl tl+ then return (List (hd ++ (unpl tl)))+ else if isdl tl+ then return (DottedList (hd ++ (unpdlh tl)) (unpdlt tl))+ else return (DottedList hd tl)+ where isl (List ((Symbol sym):_)) =+ if sym == "unquote" || sym == "unquote-splicing"+ then False+ else True+ isl (List _) = True+ isl _ = False+ unpl (List l) = l+ isdl (DottedList _ _) = True+ isdl _ = False+ unpdlh (DottedList h _) = h+ unpdlt (DottedList _ t) = t++-- Parser for a vector: this is similar to a list (but not a dotted-list),+-- except that R6RS says access times are generally faster than for lists.+-- It would seem that haskell Arrays would be the natural way to go, but+-- the documentation for those is... well, crappy. Data.IntMap is much+-- better documented, and pretty close to what we want. Access times aren't+-- O(1), but they are O(min(n,W)), where n is the size of the vector and+-- W is the size in bits of a machine word: either 32 or 64 usually. This+-- is due to the implementation of Data.IntMap: internally, it's a PATRICIA+-- tree. That should be fast enough for the moment; if it becomes an issue,+-- I can always change later. Data.IntMaps are extensible, so I could in+-- principle have extensible vectors, which would mean I'd not need to store+-- the length, but bounds-checked arrays seem like a nice feature to have;+-- I can add an explicit grow-vector routine, which as a result of the+-- extensibility of Data.IntMaps will be very easy to write.++parseVector :: Parser LispVal+parseVector =+ do char '#'+ char '('+ skipMany space+ vals <- sepBy parseExpr spaces+ skipMany space+ char ')'+ return (Vector (toInteger (length vals))+ (DIM.fromAscList (addkey 0 vals)))+ where addkey _ [] = []+ addkey n (v:vs) = (n, v):(addkey (n+1) vs)++parseExpr :: Parser LispVal+parseExpr = parseString+ <|> (TPCP.try parseBool)+ <|> (TPCP.try parseChar)+ <|> (TPCP.try parseNumber)+ <|> (TPCP.try parseVector)+ <|> (TPCP.try parseSymbol)+ <|> parseQuoted+ <|> parseDottedList++readOrThrow :: Parser a -> String -> ThrowsError a+readOrThrow parser input =+ case parse parser "lisp" input of+ Left err -> throwError (Parser err)+ Right val -> return val++readExpr :: String -> ThrowsError LispVal+readExpr = readOrThrow parseExpr++readExprList :: String -> ThrowsError [LispVal]+readExprList =+ readOrThrow ((optional hashbang) >>+ (skipMany spaces) >>+ endBy parseExpr (spaces <|> eof))++-- Parser for just numbers, for internally converting strings to numbers;+-- it's just a little more lenient than only and exactly a number: allow+-- whitespace on either side, that doesn't harm anything and seems polite++parseJustNumber :: Parser LispVal+parseJustNumber =+ do skipMany space+ num <- parseNumber+ skipMany space+ eof+ return num++readNumber :: String -> ThrowsError LispVal+readNumber input =+ case parse parseJustNumber "number" input of+ Left _ -> return (Bool False)+ Right val -> return val
+ README view
@@ -0,0 +1,34 @@+This is haskeem, a small scheme interpreter. It lives on the web at++ http://www.korgwal.com/haskeem/++You should be able to build it with++ cabal configure+ cabal build++Once you have done so, find the haskeem executable and run it.+At the "lisp> " prompt, type (assuming you are still in the top-level+haskeem directory)++ (load "stdlib.scm")+ (load "selftest.scm")++The first command loads haskeem's standard library, and the second command+runs the self-test. Assuming that all works, you can automate some of this:+copy the haskeem executable and the stdlib.scm file to some standard+location(s), and then set the environment variable HASKEEM_INIT to the+absolute path of the stdlib.scm file. I store both the haskeem executable+and the stdlib.scm file in /home/uwe/tools, which is in my PATH, and thus+I set HASKEEM_INIT to /home/uwe/tools/stdlib.scm. Then I (and you) can launch+haskeem from any directory.++If you do not have haskeline installed, don't panic! There is an alternate+version of the main module in the file haskeem_readline.hs. That provides+either a binding to the gnu readline library, or an alternate REPL with no+line-editing capability at all. You'll need to rename this to haskeem.hs,+edit it to select which of the two you want, and rebuild.++Sorry, no bindings to editline.++Enjoy!
+ Setup.hs view
@@ -0,0 +1,3 @@+module Main where+import Distribution.Simple+main = defaultMain
+ WriteNumber.hs view
@@ -0,0 +1,253 @@+{- Copyright 2008 Uwe Hollerbach <uh@alumni.caltech.edu>+Portions of this were derived from Jonathan Tang's haskell+tutorial "Write yourself a scheme in 48 hours" and are thus+Copyright Jonathan Tang+(but I can't easily tell anymore who originally wrote what)++This file is part of haskeem.+haskeem is free software; you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation; either version 2 of the License, or+(at your option) any later version.++haskeem is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+GNU General Public License for more details.++You should have received a copy of the GNU General Public License+along with haskeem; if not, write to the Free Software+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA++$Id: writenumber.hs,v 1.14 2009-05-31 01:41:08 uwe Exp $ -}++module WriteNumber (writeNum, ilogb) where+import Prelude+import Numeric+import Data.Ratio+import Maybe+import Control.Monad.Error as CME++import LispData++-- Generate the base prefix for a number. This is included explicitly in all+-- numbers generated by writeNum: that is contrary to what R6RS says; however,+-- I don't understand the rationale: what's the point of having "deadbeef"+-- floating around if you don't mark it as a number (if it is one)?++prefix :: Integer -> String+prefix 2 = "#b"+prefix 8 = "#o"+prefix 10 = "" -- implicit decimal, or "#d" if explicit prefix is desired+prefix 16 = "#x"++-- Exponent marker for floating-point numbers in scientific notation:+-- if we just use 'e' all the time, it makes base-16 numbers ambiguous,+-- so write 'x' for base-16. The parser understands this.++emark :: Integer -> String+emark n | n == 16 = "x"+ | otherwise = "e"++sign :: (Num a, Ord a) => a -> String+sign n | n < 0 = "-"+ | otherwise = "" -- or "+" if explicit sign is desired++sign2 :: Integer -> Integer -> String+sign2 n d | d == 0 = sign n -- to distinguish -1/0 from 1/0+ | otherwise = sign (n*d)++d2c :: Int -> Char+d2c d = ("0123456789abcdef" !! d)++shi :: Integer -> Integer -> String+shi b n = showIntAtBase b d2c n ""++-- fast integer base-b log: this is exported for use in the library+-- as well as here++ilogb :: Integer -> Integer -> Integer+ilogb b n | n < 0 = ilogb b (- n)+ | n < b = 0+ | otherwise = (up 1) - 1+ where up a = if n < (b ^ a)+ then bin (quot a 2) a+ else up (2*a)+ bin lo hi = if (hi - lo) <= 1+ then hi+ else let av = quot (lo + hi) 2+ in if n < (b ^ av)+ then bin lo av+ else bin av hi++-- A small limitation: some of the lengths of strings are Int not Integer,+-- so all of the specified-precision stuff is is limited to somewhere around+-- MAXINT decimal places. That seems ok for now... even the minimum Int+-- size of 2^29 is pretty damned big for a number of digits.++writeInt :: Integer -> Integer -> Maybe Integer -> String+writeInt n b p =+ let pval = fromJust p+ nval = (shi b (abs n))+ hdr = (prefix b) ++ (sign n)+ in if isNothing p+ then hdr ++ nval+ else if pval >= 0+ then hdr ++ nval ++ "." ++ (replicate (fromInteger pval) '0')+ else writeRatE (fromInteger n) b (-pval)++-- The non-finite rationals get treated specially: they get written+-- in rational format regardless of whether we specified a precision++isSpRat :: Rational -> Bool+isSpRat n = (n == myRatNaN) || (n == myRatPInf) || (n == myRatNInf)++writeSpRat :: Rational -> [Char]+writeSpRat n | n == myRatNaN = "0/0"+ | n == myRatPInf = "1/0"+ | n == myRatNInf = "-1/0"++-- this is pretty complicated, but it's all pure, and because haskell+-- is lazy only those parts which are needed will get evaluated++writeRatF :: Rational -> Integer -> Maybe Integer -> String+writeRatF num b p =+ let n = numerator num+ d = denominator num+ an = (abs n)+ ad = (abs d)+ pval = fromJust p+ nval = (abs num)+ (ni, nr) = quotRem an ad+ pfrac = b ^ pval+ nf = nr * pfrac+ (nj, ns) = quotRem nf ad+ nt = 2*ns+ ng = if (nt < ad) || ((nt == ad) && (even nj)) then nj else nj + 1+ (carry, remder) = quotRem ng pfrac+ intp = shi b (ni + carry)+ fnz = shi b remder+ len = fromInteger (pval - (toInteger (length fnz)))+ fracp = (replicate len '0') ++ fnz+ hdr = (prefix b) ++ (sign2 n d)+ in if isNothing p+ then hdr ++ (shi b an) ++ "/" ++ (shi b ad)+ else if pval > 0+ then hdr ++ intp ++ "." ++ fracp+ else if pval == 0+ then hdr ++ (shi b (round nval)) ++ "."+ else writeRatE num b (-pval)++-- Normalize a rational number n such that it's in the half-open interval+-- [1, b), and return the scaled number and the logarithmic scale factor+-- required to get it there. The funky stuff with (sn2,lb2) etc is to+-- eliminate possible errors due to inaccuracy in calculating logBase.++normTo :: Rational -> Integer -> (Rational, Integer)+normTo n b =+ let iln = ilogb 2 (numerator n)+ ild = ilogb 2 (denominator n)+ lb0 = (fromInteger (iln - ild))/(logBase 2.0 (fromInteger b))+ lb1 = toInteger (floor lb0)+ rb = fromInteger b+ sn1 = if lb1 >= 0+ then (n / (fromInteger (b ^ lb1)))+ else (n * (fromInteger (b ^ (-lb1))))+ (sn2, lb2) = if sn1 >= 1+ then (sn1, lb1)+ else (sn1 * rb, lb1 - 1)+ in if sn2 < rb+ then (sn2, lb2)+ else (sn2 / rb, lb2 + 1)++writeRatE :: Rational -> Integer -> Integer -> String+writeRatE num b p =+ let (sn, se) = normTo (abs num) b+ snr = sn/(fromInteger b)+ ser = se+1+ str = (writeRatF ((signum num)*sn) b (Just (abs p))) ++ (ssuf se)+ strr = (writeRatF ((signum num)*snr) b (Just (abs p))) ++ (ssuf ser)+ in if num == 0+ then (writeRatF (0%1) b (Just (abs p))) ++ (ssuf 0)+ else if noround str+ then str+ else strr+ where ssuf e = (emark b) ++ (sign e) ++ (shi b (abs e))+ noround s = chek (takeWhile (/= '.') s)+ chek ('#':_:rest) = chek rest+ chek ('-':rest) = chek rest+ chek "10" = False+ chek _ = True++-- The non-finite floating-point numbers get treated specially.++isSpFlt :: RealFloat a => a -> Bool+isSpFlt n = (isNaN n) || (isInfinite n)++writeSpFlt :: RealFloat a => a -> String+writeSpFlt n | n > 0 = "+inf.0"+ | n < 0 = "-inf.0"+ | otherwise = "+nan.0"++showFltAtBase :: Integer -> Double -> String+showFltAtBase b x =+ let ((f:r),e) = floatToDigits b x+ in (d2c f):("." ++ (map d2c r) ++ (emark b) +++ (sign (e - 1)) ++ (shi b (toInteger (abs (e - 1)))))++writeFlt :: Double -> Integer -> Maybe Integer -> String+writeFlt n b p =+ if isNothing p+ then (prefix b) ++ (sign n) ++ (showFltAtBase b (abs n))+ else writeRatF (toRational n) b p++goodBase :: Integer -> Bool+goodBase b = (b == 2 || b == 8 || b == 10 || b == 16)++badBase b =+ throwError (Default ("bad base " ++ (show b) ++ " in number->string"))++writeNum :: [LispVal] -> ThrowsError LispVal++writeNum [IntNumber n] = return (String (writeInt n 10 Nothing))+writeNum [IntNumber n, IntNumber b] =+ if goodBase b+ then return (String (writeInt n b Nothing))+ else badBase b+writeNum [IntNumber n, IntNumber b, IntNumber p] =+ if goodBase b+ then return (String (writeInt n b (Just p)))+ else badBase b++writeNum [RatNumber n] = writeNum [RatNumber n, IntNumber 10]+writeNum [RatNumber n, IntNumber b] =+ if isSpRat n+ then return (String (writeSpRat n))+ else if goodBase b+ then return (String (writeRatF n b Nothing))+ else badBase b+writeNum [RatNumber n, IntNumber b, IntNumber p] =+ if isSpRat n+ then return (String (writeSpRat n))+ else if goodBase b+ then return (String (writeRatF n b (Just p)))+ else badBase b++writeNum [FltNumber n] = writeNum [FltNumber n, IntNumber 10]+writeNum [FltNumber n, IntNumber b] =+ if isSpFlt n+ then return (String (writeSpFlt n))+ else if goodBase b+ then return (String (writeFlt n b Nothing))+ else badBase b+writeNum [FltNumber n, IntNumber b, IntNumber p] =+ if isSpFlt n+ then return (String (writeSpFlt n))+ else if goodBase b+ then return (String (writeFlt n b (Just p)))+ else badBase b++writeNum badArgList =+ if length badArgList <= 3+ then throwError (TypeMismatch "number->string" "number" (badArgList !! 0))+ else throwError (NumArgs "number->string" 3 badArgList)
+ fibo.scm view
@@ -0,0 +1,63 @@+; Fibonacci routines, good & bad: these also show how to use trace+; $Id: fibo.scm,v 1.2 2009-05-26 04:22:10 uwe Exp $++; efficient Fibonacci function: use accumulator to calculate in linear time++(define (fibo n)+ (define (fibo-acc i a1 a2)+ (if (= i 1)+ a1+ (fibo-acc (- i 1) (+ a1 a2) a1)))+ (trace fibo-acc #t)+ (cond ((< n 1) 0)+ ((= n 1) 1)+ (else (fibo-acc n 1 0))))++; inefficient Fibonacci function: straight from definition,+; but exponential time++(define (bad-fibo n)+ (cond ((< n 1) 0)+ ((= n 1) 1)+ (else (+ (bad-fibo (- n 1)) (bad-fibo (- n 2))))))+(trace bad-fibo #t)++; identical to bad-fibo, defined just so that we have an independent+; copy to play with++(define (memo-fibo n)+ (cond ((< n 1) 0)+ ((= n 1) 1)+ (else (+ (memo-fibo (- n 1)) (memo-fibo (- n 2))))))+(trace memo-fibo #t)++; cache access: a cache is a list of dotted-pairs, with the car of+; each pair being the argument, and the cdr being the function value.+; return (#t . fval) if found, (#f . #f) if not found++(define (get-cache cache in)+ (cond ((null? cache) (cons #f #f))+ ((eqv? (caar cache) in) (cons #t (cdar cache)))+ (else (get-cache (cdr cache) in))))++; return a memoized version of the given function++(define (memoize fn)+ (if (procedure? fn)+ (let ((cache ()))+ (lambda (arg)+ (let ((cval (get-cache cache arg)))+ (if (car cval)+ (cdr cval)+ (let ((nval (fn arg)))+ (set! cache (cons (cons arg nval) cache))+ nval)))))+ fn))++(write-string "Defined (fibo n), (bad-fibo n), and (memo-fibo n)\n"+ "(bad-fibo) and (memo-fibo) act identically until you run\n"+ "\n"+ "\t(set! memo-fibo (memoize memo-fibo))\n"+ "\n"+ "then, shazam! (memo-fibo) will act just like (fibo)\n"+ "(actually, even better)\n")
+ gendoc.scm view
@@ -0,0 +1,67 @@+; Copyright 2008 Uwe Hollerbach <uh@alumni.caltech.edu>++; This file is part of haskeem.+; haskeem is free software; you can redistribute it and/or modify+; it under the terms of the GNU General Public License as published by+; the Free Software Foundation; either version 2 of the License, or+; (at your option) any later version.++; haskeem is distributed in the hope that it will be useful,+; but WITHOUT ANY WARRANTY; without even the implied warranty of+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+; GNU General Public License for more details.++; You should have received a copy of the GNU General Public License+; along with haskeem; if not, write to the Free Software+; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA++; $Id: gendoc.scm,v 1.5 2008/02/10 06:32:20 uwe Exp $++; A small documentation generator: it reads the file "haskeem.doc" and+; processes its contents into the desired format... currently just a+; sorted list to stdout++; How to sort doc items: first by section, then within each section by name.+; Sections are are identified by one of a couple of keywords:+; "form", "function", "primitive", "data", or "port"++(define (type-map type)+ (case type+ (("form") 1)+ (("function" "primitive") 2)+ (("data" "port") 3)+ (else 4)))++(define (doc-sort d1 d2)+ (let* ((t1 (symbol->string (caar d1)))+ (t2 (symbol->string (caar d2)))+ (m1 (type-map t1))+ (m2 (type-map t2))+ (n1 (symbol->string (cadar d1)))+ (n2 (symbol->string (cadar d2))))+ (or (< m1 m2)+ (and (= m1 m2) (string<? t1 t2))+ (and (= m1 m2) (string=? t1 t2) (string<? n1 n2)))))++(define doc-data (list-sort doc-sort (read-all "haskeem.doc")))++(define (show item)+ (let ((sect (symbol->string (caar item)))+ (args (assv 'args item))+ (ret (assv 'return item)))+ (unless (string=? section sect)+ (begin (set! section sect)+ (write-string "\nSection " sect ":\n\n")))+ (write-string " " (symbol->string (cadar item)) ": takes args ")+ (if args+ (display (cdr args))+ (write-string "<none>"))+ (write-string ", returns ")+ (if ret+ (display (cdr ret))+ (write-string "<nothing>"))+ (write-string #\linefeed)))++(define section)++(map show doc-data)
+ guard.scm view
@@ -0,0 +1,22 @@+; the first 'test', "(begin...)", is only to print out the value of+; the exception that was thrown: that 'test' always returns #f++(define (tryit test)+ (guard+ (err ((begin (write-string "exception is '")+ (display err)+ (write-string "'\n")+ #f) #t)+ ((and (string? err) (string=? err "meh"))+ (write-string "caught 'meh'\n")+ "I am the 'meh'-catcher")+ ((and (string? err) (string=? err "barf"))+ (write-string "caught 'barf'... yuk!\n")+ -42)+ ((and (string? err) (string=? err "yahoo!"))+ (write-string "a little excitable today, aren't we...\n")+ "US$44.6billion")+ ((eqv? err '(1 2))+ (write-string "does not compute\n")+ "daleks rule! (until their heads blow off)"))+ (raise test)))
+ hamming.scm view
@@ -0,0 +1,32 @@+; -- Efficiently compute Hamming numbers++; This version of stream-merge keeps only one copy of duplicate+; values. For Hamming numbers, that's exactly what we want, but+; for more general stream merging, it might not be.++(define (stream-merge strm1 strm2 cmp)+ (let ((cval (cmp (car strm1) (car strm2))))+ (cond ((< cval 0) (cons (car strm1)+ (delay (stream-merge (force (cdr strm1))+ strm2 cmp))))+ ((= cval 0) (cons (car strm1)+ (delay (stream-merge (force (cdr strm1))+ (force (cdr strm2)) cmp))))+ ((> cval 0) (cons (car strm2)+ (delay (stream-merge strm1+ (force (cdr strm2)) cmp)))))))++(define hams+ (letrec ((next+ (lambda (n)+ (cons n (delay (stream-merge+ (stream-map (lambda (n) (* 5 n)) hams)+ (stream-merge+ (stream-map (lambda (n) (* 2 n)) hams)+ (stream-map (lambda (n) (* 3 n)) hams)+ -)+ -))))))+ (next 1)))++(display (stream-head hams 200))+(write-string #\linefeed)
+ haskeem.cabal view
@@ -0,0 +1,26 @@+Name: haskeem+Version: 0.6.10+Author: Uwe Hollerbach <uh@alumni.caltech.edu>+Maintainer: Uwe Hollerbach <uh@alumni.caltech.edu>+Synopsis: A small scheme interpreter+Description: This is a moderately complete small scheme interpreter.+ It implements most of R6RS, with the exception of call/cc+ and a macro system. It is also not necessarily fully+ tail-recursive; so it's not industrial-strength. For+ playing with or learning scheme, it should be pretty good.+License: GPL+License-File: LICENSE+Cabal-Version: >= 1.2+Build-Type: Simple+Category: Compilers/Interpreters++Executable haskeem+ Build-Depends: base >= 4, network, containers, mtl, parsec, haskell98,+ random, old-time, unix, directory, haskeline+ Main-is: haskeem.hs+ Other-Modules: LispData+ Parser+ Library+ Environment+ Evaluator+ WriteNumber
+ haskeem.doc view
@@ -0,0 +1,346 @@+; Copyright 2008 Uwe Hollerbach <uh@alumni.caltech.edu>++; This file is part of haskeem.+; haskeem is free software; you can redistribute it and/or modify+; it under the terms of the GNU General Public License as published by+; the Free Software Foundation; either version 2 of the License, or+; (at your option) any later version.++; haskeem is distributed in the hope that it will be useful,+; but WITHOUT ANY WARRANTY; without even the implied warranty of+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+; GNU General Public License for more details.++; You should have received a copy of the GNU General Public License+; along with haskeem; if not, write to the Free Software+; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA++; $Id: haskeem.doc,v 1.29 2008/03/08 03:52:38 uwe Exp $++; Input to documentation generator for haskeem. The intent is that this+; does NOT have to be globally ordered, it is possible to just add new+; stuff at the end, and the gendoc program will sort and classify it+; correctly. For now I'm just trying to capture the input and return+; types, not any detailed documentation.++((form and) (args . test-values) (return boolean))+((form or) (args . test-values) (return boolean))++((form apply) (args func list))+((form apply) (args func . values))++((form begin) (args . expressions))+((form quote) (args val))++((form case) (args key . key-clauses))+((form cond) (args . cond-clauses))++((form define) (args var))+((form define) (args var val))+((form define) (args (var params) body))+((form define) (args (var params . varargs) body))++((form let) (args ???))+((form let*) (args ???))+((form letrec) (args ???))+((form letrec*) (args ???))++((form do) (args a lot))++((form eval) (args . expressions))++((form delay) (args expr) (return promise))+((form force) (args promise) (return value))++((form guard) (args a lot))++((form if) (args pred true-case false-case))+((form if) (args pred true-case))++((form unless) (args pred expression))+((form when) (args pred expression))++((form load) (args filename))++((form lambda) (args (params) body))+((form lambda) (args (params . varargs) body))+((form lambda) (args varargs body))++((form set!) (args var val))+((form trace) (args func bool))+((form dump-bindings) (args))+((form dump-bindings) (args port))++((port stdin))+((port stdout))+((port stderr))+((data pi))++((function caar) (args pair) (return value))+((function cadr) (args pair) (return value))+((function cdar) (args pair) (return value))+((function cddr) (args pair) (return value))+((function caaar) (args pair) (return value))+((function caadr) (args pair) (return value))+((function cadar) (args pair) (return value))+((function caddr) (args pair) (return value))+((function cdaar) (args pair) (return value))+((function cdadr) (args pair) (return value))+((function cddar) (args pair) (return value))+((function cdddr) (args pair) (return value))+((function caaaar) (args pair) (return value))+((function caaadr) (args pair) (return value))+((function caadar) (args pair) (return value))+((function caaddr) (args pair) (return value))+((function cadaar) (args pair) (return value))+((function cadadr) (args pair) (return value))+((function caddar) (args pair) (return value))+((function cadddr) (args pair) (return value))+((function cdaaar) (args pair) (return value))+((function cdaadr) (args pair) (return value))+((function cdadar) (args pair) (return value))+((function cdaddr) (args pair) (return value))+((function cddaar) (args pair) (return value))+((function cddadr) (args pair) (return value))+((function cdddar) (args pair) (return value))+((function cddddr) (args pair) (return value))++((function eval) (args expr))++((function flip) (args func) (return function))++((function curry) (args func arg1) (return function))++((function compose) (args func1 func2) (return function))++((function foldr) (args func end-value lst))+((function foldl) (args func accum-value lst))+((function unzip) (args list) (return (list list)))++((function list) (args . objects) (return list))+((function append) (args list . lists) (return list))++((function length) (args list) (return integer))++((function list-head) (args list n) (return list))+((function list-unhead) (args list n) (return list))+((function list-tail) (args list n) (return list))+((function list-untail) (args list n) (return list))+((function list-ref) (args list n) (return value))+((function list-unref) (args list n) (return list))+((function last) (args list) (return value))++((function map) (args func list . lists) (return list))++((function filter) (args pred lst) (return list))++((function list-sort) (args pred? list) (return list))+((function list-drop-while) (args drop? list) (return list))+((function list-take-while) (args keep? list) (return list))+((function string-split-by) (args drop? str) (return list))+((function string-join-by) (args join strs) (return string))++((function string-upcase) (args str) (return string))+((function string-downcase) (args str) (return string))++((function expmod) (args a n m) (return integer))+((function mersenne-prime?) (args e) (return boolean))++((primitive not) (args value) (return boolean))+((primitive null?) (args obj) (return boolean))+((primitive even?) (args number) (return boolean))+((primitive odd?) (args number) (return boolean))+((primitive id) (args x) (return x))+((primitive reverse) (args list) (return list))+((primitive +) (args number1 number2 . numbers) (return number))+((primitive -) (args number1 number2 . numbers) (return number))+((primitive *) (args number1 number2 . numbers) (return number))+((primitive /) (args number1 number2 . numbers) (return number))+((primitive expt) (args number1 number2) (return number))+((primitive min) (args number1 number2 . numbers) (return number))+((primitive max) (args number1 number2 . numbers) (return number))+((primitive modulo) (args number1 number2) (return number))+((primitive quotient) (args number1 number2) (return number))+((primitive remainder) (args number1 number2) (return number))+((primitive gcd) (args integer1 integer2 . integers) (return integer))+((primitive lcm) (args integer1 integer2 . integers) (return integer))+((primitive =) (args number1 number2) (return boolean))+((primitive <) (args number1 number2) (return boolean))+((primitive >) (args number1 number2) (return boolean))+((primitive /=) (args number1 number2) (return boolean))+((primitive >=) (args number1 number2) (return boolean))+((primitive <=) (args number1 number2) (return boolean))+((primitive boolean?) (args value) (return boolean))+((primitive symbol?) (args value) (return boolean))+((primitive char?) (args value) (return boolean))+((primitive number?) (args value) (return boolean))+((primitive integer?) (args value) (return boolean))+((primitive rational?) (args value) (return boolean))+((primitive real?) (args value) (return boolean))+((primitive string?) (args value) (return boolean))+((primitive pair?) (args value) (return boolean))+((primitive list?) (args value) (return boolean))+((primitive port?) (args value) (return boolean))+((primitive procedure?) (args value) (return boolean))+((primitive zero?) (args number) (return boolean))+((primitive positive?) (args number) (return boolean))+((primitive negative?) (args number) (return boolean))+((primitive nan?) (args number) (return boolean))+((primitive infinite?) (args number) (return boolean))+((primitive finite?) (args number) (return boolean))+((primitive string=?) (args string1 string2) (return boolean))+((primitive string<?) (args string1 string2) (return boolean))+((primitive string>?) (args string1 string2) (return boolean))+((primitive string>=?) (args string1 string2) (return boolean))+((primitive string<=?) (args string1 string2) (return boolean))+((primitive char=?) (args char1 char2) (return boolean))+((primitive char<?) (args char1 char2) (return boolean))+((primitive char>?) (args char1 char2) (return boolean))+((primitive char>=?) (args char1 char2) (return boolean))+((primitive char<=?) (args char1 char2) (return boolean))+((primitive char->string) (args (char . chars))) ; todo other version?+((primitive string->char) (args string) (return (character)))+((primitive string->number) (args string) (return number))+((primitive number->string) (args number) (return string))+((primitive number->string) (args number base) (return string))+((primitive symbol->string) (args symbol) (return string))+((primitive char-alphabetic?) (args character) (return boolean))+((primitive char-numeric?) (args character) (return boolean))+((primitive char-oct-digit?) (args character) (return boolean))+((primitive char-hex-digit?) (args character) (return boolean))+((primitive char-whitespace?) (args character) (return boolean))+((primitive char-upper-case?) (args character) (return boolean))+((primitive char-lower-case?) (args character) (return boolean))+((primitive char-alphanumeric?) (args character) (return boolean))+((primitive char-control?) (args character) (return boolean))+((primitive char-printable?) (args character) (return boolean))+((primitive char-upcase) (args character) (return boolean))+((primitive char-downcase) (args character) (return boolean))+((primitive car) (args pair))+((primitive cdr) (args pair))+((primitive cons) (args value1 value2))+((primitive eqv?) (args value1 value2) (return boolean))+((primitive char->integer) (args character) (return integer))+((primitive integer->char) (args number) (return character))+((primitive floor) (args number) (return integer))+((primitive truncate) (args number) (return integer))+((primitive round) (args number) (return integer))+((primitive round) (args number integer integer) (return number))+((primitive ceiling) (args number) (return integer))+((primitive numerator) (args rational) (return integer))+((primitive denominator) (args rational) (return integer))+((primitive abs) (args number) (return number))+((primitive sqrt) (args number) (return real))+((primitive exp) (args number) (return real))+((primitive log) (args number) (return real))+((primitive sin) (args number) (return real))+((primitive cos) (args number) (return real))+((primitive tan) (args number) (return real))+((primitive sinh) (args number) (return real))+((primitive cosh) (args number) (return real))+((primitive tanh) (args number) (return real))+((primitive asin) (args number) (return real))+((primitive acos) (args number) (return real))+((primitive atan) (args number) (return real))+((primitive atan) (args number1 number2) (return real))+((primitive asinh) (args number) (return real))+((primitive acosh) (args number) (return real))+((primitive atanh) (args number) (return real))++((primitive open-input-file) (args filename) (return read-port))+((primitive open-output-file) (args filename) (return write-port))+((primitive open-append-file) (args filename) (return write-port))+((primitive close-port) (args port) (return))+((primitive raise) (args string))+((primitive display) (args object) (return ))+((primitive read-line) (args port) (return string))+((primitive read-char) (args port) (return character))+((primitive read-contents) (args filename) (return string))+((primitive read-all) (args filename) (return list))+((primitive write-string) (args string-or-character . str-or-chars) (return ))+((primitive write-string)+ (args port string-or-character . str-or-chars) (return ))+((primitive flush-port) (args port) (return ))+((primitive exit) (args status))++((function find) (args proc list) (return value))+((function partition) (args pred list) (return (list list)))+((function assp) (args test? list) (return pair))+((function assv) (args obj list) (return pair))+((function memp) (args test? list) (return list))+((function memv) (args obj list) (return list))++((function stream-head) (args stream n) (return list))+((function stream-map) (args func stream . streams) (return stream))+((primitive rename-file) (args oldname newname) (return bool))+((primitive remove-file) (args filename) (return bool))+((primitive get-current-directory) (args) (return directory-path))+((primitive set-current-directory) (args directory-path) (return bool))+((primitive read-directory) (args directory-path) (return (string)))+((primitive file-exists?) (args filename) (return bool))+((primitive directory-exists?) (args dirname) (return bool))+((primitive get-environment) (args environment-variable) (return string))+((primitive get-environment) (args) (return (string . string)))+((primitive set-environment) (args key val))+((primitive unset-environment) (args key))+((primitive epochtime) (args) (return number))+((primitive localtime) (args) (return string))+((primitive localtime) (args n) (return string))+((primitive UTCtime) (args) (return string))+((primitive UTCtime) (args n) (return string))+((function exact-integer-sqrt) (args number) (return (number number)))+((function exact-integer-cbrt) (args number) (return (number number)))+((function for-each) (args proc list . lists))+((function for-all-combinations) (args proc . lsts))++((function replicate) (args val n) (return list))+((function upfrom) (args start n) (return list))+((function list-tabulate) (args n proc) (return list))+((function cputime) (args) (return number))+((function get-file-status) (args filename) (return list))+((function get-link-status) (args filename) (return list))+((function is-block-device?) (args filename) (return bool))+((function is-char-device?) (args filename) (return bool))+((function is-named-pipe?) (args filename) (return bool))+((function is-regular-file?) (args filename) (return bool))+((function is-directory?) (args filename) (return bool))+((function is-symbolic-link?) (args filename) (return bool))+((function is-socket?) (args filename) (return bool))+((function create-link) (args old-name new-name) (return bool))+((function create-symbolic-link) (args old-name new-name) (return bool))+((primitive ilog) (args integer) (return integer))+((primitive ilog) (args integer integer) (return integer))+((primitive factorial) (args integer) (return integer))+((primitive make-vector) (args integer) (return vector))+((primitive make-vector) (args integer value) (return vector))+((primitive vector) (args (values)) (return vector))+((primitive list->vector) (args list) (return vector))+((primitive vector->list) (args vector) (return list))+((primitive vector-length) (args vector) (return integer))+((primitive vector-ref) (args vector integer) (return value))+((form vector-set!) (args var index value) (return vector))+((form vector-fill!) (args var value) (return vector))+((form vector-resize!) (args var new-size) (return vector))+((function vector-for-each) (args proc vector . vectors) (return vector))+((form quasiquote))+((form unquote))+((form unquote-splicing))+((primitive random-uniform) (args) (return real))+((primitive random-uniform) (args lo-int hi-int) (return integer))+((primitive random-uniform) (args lo-flt hi-flt) (return real))+((primitive random-exponential) (args) (return real))+((primitive random-exponential) (args number) (return real))+((primitive random-normal-pair) (args) (return (real real)))+((primitive random-normal-pair) (args mean sdev) (return (real real)))+((primitive random-poisson) (args lambda) (return integer))+((primitive random-seed!) (args integer))+((primitive random-seed!) (args string))+((primitive connect-to) (args hostname port) (return port))+((primitive connect-to) (args hostname unix-socket) (return port))+((primitive listen-on) (args port) (return socket-descriptor))+((primitive listen-on) (args unix-socket) (return socket-descriptor))+((primitive accept) (args socket) (return (handle hostname port)))+((primitive set-line-buffering!) (args handle))+((primitive set-no-buffering!) (args handle))+((function stream-scale) (args scale stream) (return stream))+((function assert) (args expr) (return expr-value))
+ haskeem.hs view
@@ -0,0 +1,135 @@+{- Copyright 2008 Uwe Hollerbach <uh@alumni.caltech.edu>+Portions of this were derived from Jonathan Tang's haskell+tutorial "Write yourself a scheme in 48 hours" and are thus+Copyright Jonathan Tang+(but I can't easily tell anymore who originally wrote what)++This file is part of haskeem.+haskeem is free software; you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation; either version 2 of the License, or+(at your option) any later version.++haskeem is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+GNU General Public License for more details.++You should have received a copy of the GNU General Public License+along with haskeem; if not, write to the Free Software+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA++$Id: haskeem.hs,v 1.26 2009-05-31 01:41:07 uwe Exp $ -}++module Main where+import Prelude+import IO+import System+import Monad()+import Control.Monad.Error as CME+import Control.OldException as CE+import Data.Char+import System.Console.Haskeline+import System.Posix.Signals()+import Control.Concurrent()+import Data.Typeable()++import LispData+import Parser+import Evaluator+import Environment+import Library++-- haskeem version++version :: String+version = "0.6.10"++-- a variable under which any command-line arguments to a script are+-- made available; empty for interactive mode++scriptArgs :: String+scriptArgs = "args"++-- a variable which is initially set to #t for the REPL, #f for script mode++interactive :: String+interactive = "interactive?"++-- the "EP" of the REPL, but also used in non-interactive parts:+-- the boolean "print" arg controls whether results are printed+-- (but errors are always printed)++evalAndPrint :: Env -> Bool -> String -> InputT IO ()+evalAndPrint env pflag expr =+ do ret <- liftIO (runErrorT (liftThrows (readExpr expr) >>= evalLisp env 0))+ case ret of+ Left err -> outputStrLn (show err)+ Right val -> if pflag then outputStrLn (show val) else outputStr ""+ return ()++-- if the environment variable HASKEEM_INIT is set, try to load that file++runInit :: Env -> InputT IO ()+runInit env =+ (do ret <- liftIO (CE.try (getEnv "HASKEEM_INIT"))+ case ret of+ Left err -> return ("(write-string \"no init file loaded: " +++ show err ++ "\n\")")+ Right val -> return ("(load \"" ++ val ++ "\")")) >>=+ evalAndPrint env False++-- set up bindings: primitives plus additional variables determined here++setupBindings :: [LispVal] -> Bool -> IO Env+setupBindings args inter =+ primitiveBindings >>= flip bindVars [(scriptArgs, List args),+ (interactive, Bool inter)]++-- interactive mode: print header, run initialization, then dive into REPL++writeHdr :: String -> IO ()+writeHdr prog =+ hPutStrLn stderr+ ("This is " ++ prog ++ " " ++ version +++ " -- scheme in haskell\n" +++ "Derived from Jonathan Tang's tutorial \"scheme in 48\"\n" +++ "Copyright 2008 Uwe Hollerbach <uh@alumni.caltech.edu>\n" +++ "Available under GPL V2 or later. Share and enjoy!\n" +++ "http://www.korgwal.com/haskeem/\n")++-- the actual REPL, combined with tasty haskeline goodness++doREPL :: Env -> InputT IO ()+doREPL env =+ do maybeLine <- getInputLine "lisp> "+ case maybeLine of + Nothing -> outputStrLn "g'bye!" >> return ()+ Just "quit" -> return ()+ Just line -> if isBlank line+ then doREPL env+ else evalAndPrint env True line >> doREPL env+ where isBlank [] = True+ isBlank _ = False++runREPL :: IO ()+runREPL =+ do getProgName >>= writeHdr+ env <- setupBindings [] True+ runInputT defaultSettings (runInit env >> doREPL env)++-- non-interactive mode: do initialization, then run a script+-- specified on the command line, with any extra args stored in the+-- top-level args variable defined above++runOne :: [String] -> IO ()+runOne args =+ do env <- setupBindings (map String (drop 1 args)) False+ runInputT defaultSettings+ (runInit env >>+ evalAndPrint env False ("(load \"" ++ (args !! 0) ++ "\")"))++main :: IO ()+main =+ do args <- getArgs+ if null args then runREPL else runOne args
+ haskeem_readline.hs view
@@ -0,0 +1,159 @@+{- Copyright 2008 Uwe Hollerbach <uh@alumni.caltech.edu>+Portions of this were derived from Jonathan Tang's haskell+tutorial "Write yourself a scheme in 48 hours" and are thus+Copyright Jonathan Tang+(but I can't easily tell anymore who originally wrote what)++This file is part of haskeem.+haskeem is free software; you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation; either version 2 of the License, or+(at your option) any later version.++haskeem is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+GNU General Public License for more details.++You should have received a copy of the GNU General Public License+along with haskeem; if not, write to the Free Software+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA++$Id: haskeem.hs,v 1.24 2008-03-06 03:09:43 uwe Exp $ -}++module Main where+import Prelude+import IO+import System+import Monad+import Control.Monad.Error as CME+import Control.OldException as CE+import Data.Char+-- import System.Console.Readline+import System.Posix.Signals+import Control.Concurrent+import Data.Typeable++import LispData+import Parser+import Evaluator+import Environment+import Library++-- haskeem version++version :: String+version = "0.6.9"++-- a variable under which any command-line arguments to a script are+-- made available; empty for interactive mode++scriptArgs :: String+scriptArgs = "args"++-- a variable which is initially set to #t for the REPL, #f for script mode++interactive :: String+interactive = "interactive?"++-- the "EP" of the REPL, but also used in non-interactive parts:+-- the boolean "print" arg controls whether results are printed+-- (but errors are always printed)++evalAndPrint :: Env -> Bool -> String -> IO ()+evalAndPrint env print expr =+ do ret <- runErrorT (liftThrows (readExpr expr) >>= evalLisp env 0)+ case ret of+ Left err -> hPutStrLn stderr (show err)+ Right val -> if print then putStrLn (show val) else putStr ""++-- if the environment variable HASKEEM_INIT is set, try to load that file++runInit :: Env -> IO ()+runInit env =+ (do ret <- CE.try (getEnv "HASKEEM_INIT")+ case ret of+ Left err -> return "(write-string \"no init file loaded\n\")"+ Right val -> return ("(load \"" ++ val ++ "\")")) >>=+ evalAndPrint env False++-- set up bindings: primitives plus additional variables determined here++setupBindings :: [LispVal] -> Bool -> IO Env+setupBindings args inter =+ primitiveBindings >>= flip bindVars [(scriptArgs, List args),+ (interactive, Bool inter)]++-- interactive mode: print header, run initialization, then dive into REPL++writeHdr prog =+ hPutStrLn stderr+ ("This is " ++ prog ++ " " ++ version +++ " -- scheme in haskell\n" +++ "Derived from Jonathan Tang's tutorial \"scheme in 48\"\n" +++ "Copyright 2008 Uwe Hollerbach <uh@alumni.caltech.edu>\n" +++ "Available under GPL V2 or later. Share and enjoy!\n" +++ "http://www.korgwal.com/haskeem/\n")++-- this readline and addHistory are for machines without gnu readline++readline :: String -> IO (Maybe String)+readline prompt =+ do putStr prompt+ hFlush stdout+ ret <- CE.try (getLine)+ case ret of+ Left err -> do hPutStrLn stderr "g'bye!"+ exitWith (ExitFailure 1)+ Right val -> return (Just val)++addHistory :: String -> IO ()+addHistory foo = putStr ""++-- the actual REPL, combined with tasty gnu readline goodness++data MyInterrupt = MyInt deriving Typeable++catcher :: MyInterrupt -> IO ()+catcher e = hPutStrLn stderr "Interrupt!"++doREPL :: Env -> IO ()+doREPL env =+ do maybeLine <- readline "lisp> "+ case maybeLine of + Nothing -> putStrLn "g'bye!"+ Just "quit" -> return ()+ Just line -> if isBlank line+ then doREPL env+ else do addHistory line+ catchDyn (evalAndPrint env True line)+ (\e -> catcher e)+ doREPL env+ where isBlank [] = True+ isBlank _ = False++mysighandler tid = Catch (throwDynTo tid MyInt)++runREPL :: IO ()+runREPL =+ do getProgName >>= writeHdr+ env <- setupBindings [] True+ runInit env+ tid <- myThreadId+ installHandler sigINT (mysighandler tid) Nothing+ installHandler sigQUIT (mysighandler tid) Nothing+ doREPL env++-- non-interactive mode: do initialization, then run a script+-- specified on the command line, with any extra args stored in the+-- top-level args variable defined above++runOne :: [String] -> IO ()+runOne args =+ do env <- setupBindings (map String (drop 1 args)) False+ runInit env+ evalAndPrint env False ("(load \"" ++ (args !! 0) ++ "\")")++main =+ do args <- getArgs+ if null args then runREPL else runOne args
+ powerseries.scm view
@@ -0,0 +1,226 @@+; $Id: powerseries.scm,v 1.9 2008/03/08 03:52:39 uwe Exp $++; A small package for manipulating power series implemented as streams.+; There is nothing here that forces the use of floating-point, so if user+; inputs are integers or rationals, the results will also be rational; this+; is nice for getting out exact results.++; The stream of natural numbers (0 1 2 3 ...),+; useful as a building block for stuff below++(define ps-nat-numbers+ (letrec ((next+ (lambda (n)+ (cons n (delay (next (+ n 1)))))))+ (next 0)))++; Some functions for power-series specifically++; negation, addition, and subtraction are trivial++(define (ps-neg ps) (stream-scale -1 ps))+(define (ps-add ps . pss) (apply stream-map (append (list + ps) pss)))+(define (ps-sub ps . pss) (apply stream-map (append (list - ps) pss)))++; multiplication and reciprocal are a little less trivial++(define (ps-mul ps1 ps2)+ (let ((h1 (car ps1))+ (h2 (car ps2))+ (t1 (cdr ps1))+ (t2 (cdr ps2)))+ (cons (* h1 h2) (delay (ps-add (stream-scale h1 (force t2))+ (stream-scale h2 (force t1))+ (cons 0 (ps-mul (force t1) (force t2))))))))++; It is an error to take the reciprocal of a power series without a constant+; term because such a resulting series is not representable as a power+; series: it contains negative powers of x, and these cause infinities at x+; = 0. It would be a Laurent series, and we don't handle these.++(define (ps-recip ps)+ (when (zero? (car ps))+ (raise "ps-recip error: power series has no constant term!"))+ (letrec* ((r (cons 1 (delay (ps-neg (ps-mul r (fcdr ps)))))))+ (stream-scale (/ (car ps)) r)))++; division is trivial when expressed in terms of reciprocal++(define (ps-div ps1 ps2) (ps-mul ps1 (ps-recip ps2)))++; Term-by-term differentiation and integration++(define (ps-derivative ps) (fcdr (stream-map * ps-nat-numbers ps)))++(define (ps-integral ps ctrm)+ (cons ctrm (stream-map / ps (fcdr ps-nat-numbers))))++; Semi-evaluate a power-series by multiplying each term by a specific x+; raised to the Nth power; the sum of all of these is the actual value of+; the expression, which may be approximated by the ps-sums routine below.++(define (ps-eval ps x)+ (stream-map * ps (stream-map (lambda (n) (expt x n)) ps-nat-numbers)))++; The stream of partial sums of the input++(define (ps-sums ps)+ (letrec ((accfn (lambda (acc str)+ (set! acc (+ acc (car str)))+ (cons acc (delay (accfn acc (fcdr str)))))))+ (accfn 0 ps)))++; TODO: Aitken acceleration formula (but is x_k here the kth term, or+; the kth partial sum??? check that!)+; new estimate = x_k - (x_{k+1} - x_k)^2/(x_{k+2} - 2*x_{k+1} + x_k)++; And some actual power series++; geometric series 1/(1 - x)++(define ps-geom (stream-map (lambda (n) 1) ps-nat-numbers))++(define ps-exp (stream-map (lambda (n) (/ (factorial n))) ps-nat-numbers))++; ln(1+x) -- valid only for -1 < x <= 1+; note that this converges *very* slowly for |x| near 1++(define ps-logxp1+ (cons 0 (stream-map+ (lambda (n) (/ (expt -1 (+ n 1)) n)) (fcdr ps-nat-numbers))))++(define ps-sin (stream-map+ (lambda (n)+ (if (even? n)+ 0+ (/ (expt -1 (quotient (- n 1) 2))+ (factorial n))))+ ps-nat-numbers))++(define ps-cos (stream-map+ (lambda (n)+ (if (odd? n)+ 0+ (/ (expt -1 (quotient n 2))+ (factorial n))))+ ps-nat-numbers))++(define ps-tan (ps-div ps-sin ps-cos))++(define ps-atan (stream-map+ (lambda (n)+ (if (even? n)+ 0+ (/ (expt -1 (quotient (- n 1) 2)) n)))+ ps-nat-numbers))++(define ps-sinh (stream-map+ (lambda (n)+ (if (even? n)+ 0+ (/ (factorial n)))) ps-nat-numbers))++(define ps-cosh (stream-map+ (lambda (n)+ (if (odd? n)+ 0+ (/ (factorial n)))) ps-nat-numbers))++(define ps-tanh (ps-div ps-sinh ps-cosh))++(define ps-atanh (stream-map+ (lambda (n)+ (if (even? n)+ 0+ (/ n))) ps-nat-numbers))++; exp(-x^2)++(define ps-gaussian (stream-map+ (lambda (n)+ (if (odd? n)+ 0+ (begin (set! n (quotient n 2))+ (/ (expt -1 n)+ (factorial n))))) ps-nat-numbers))++; This is actually not quite Erf(x): there is a scale factor of 1/sqrt(pi)+; missing. I'm leaving that out so that stuff doesn't get forced to+; floating-point, since I don't have an infinite-precision rational version+; of (sqrt pi).++(define ps-erf (stream-scale 2 (ps-integral ps-gaussian 0)))++; Bessel functions J_n for integer n >= 0:+;+; (-1)^m x^(2*m)+; J_n = x^n * sum_m=0^infinity -------------------+; 2^(2*m+n)*m!*(m+n)!++(define (ps-bessel-j n)+ (when (negative? n)+ (raise "ps-bessel-j can't handle negative n!"))+ (letrec ((term-fn (lambda (m2)+ (if (odd? m2)+ 0+ (let ((m (quotient m2 2)))+ (/ (expt -1 m)+ (* (expt 2 (+ m2 n))+ (factorial m)+ (factorial (+ m n))))))))+ (cons-fn (lambda (m obj)+ (if (zero? m)+ obj+ (cons 0 (cons-fn (- m 1) obj))))))+ (cons-fn n (stream-map term-fn ps-nat-numbers))))++; Bessel functions I_n for integer n >= 0:+;+; x^(2*m)+; I_n = x^n * sum_m=0^infinity -------------------+; 2^(2*m+n)*m!*(m+n)!++(define (ps-bessel-i n)+ (when (negative? n)+ (raise "ps-bessel-i can't handle negative n!"))+ (letrec ((term-fn (lambda (m2)+ (if (odd? m2)+ 0+ (let ((m (quotient m2 2)))+ (/ (* (expt 2 (+ m2 n))+ (factorial m)+ (factorial (+ m n))))))))+ (cons-fn (lambda (m obj)+ (if (zero? m)+ obj+ (cons 0 (cons-fn (- m 1) obj))))))+ (cons-fn n (stream-map term-fn ps-nat-numbers))))++; Lambert W function: this satisfies the implicit equation W*exp(W) = x.+; This series converges for |x| < exp(-1). The function is multi-valued+; for -exp(-1) < x < 0; this series converges to the value closest to 0.++(define ps-lambert-w+ (cons 0 (stream-map+ (lambda (n) (/ (expt (- n) (- n 1)) (factorial n)))+ (fcdr ps-nat-numbers))))++; A couple of small utility functions to more easily show streams and+; tabulate values++(define (ps-show n p strm)+ (if (zero? p)+ (for-each (lambda (val)+ (write-string (number->string val 10) #\linefeed))+ (stream-head strm n))+ (for-each (lambda (val)+ (write-string (number->string val 10 p) #\linefeed))+ (stream-head strm n))))++(define (ps-table fn nterms lo hi step)+ (do ((x lo (+ x step)))+ ((> x hi) #t)+ (write-string (number->string x 10 8) #\tab+ (number->string (last (stream-head+ (ps-sums (ps-eval fn x)) nterms))+ 10 -8) #\linefeed)))
+ primes.scm view
@@ -0,0 +1,41 @@+; $Id: primes.scm,v 1.2 2008/02/10 06:32:20 uwe Exp $+; Play with prime numbers++; Define an initial set of the lowest couple of primes; only (2 3) is+; strictly necessary, but those two are: the (grow-primes-table)+; routine steps by 2, and that would fail if we had just (2) as the+; initial primes table++(define primes '(2 3 5 7))++; Check a number for primality. This is kinda cute, in that I'm using+; the exception-handling mechanism to simplify the testing: I could+; have a complicated test to determine if I can exit the do-loop, and+; then another test to determine what the value should be, but that's+; a mess. This is much cleaner.++(define (is-prime? n)+ (guard (err ((boolean? err) err))+ (do ((pl primes (cdr pl))+ (cur 0))+ ((null? pl) (raise "exhausted primes list!"))+ (set! cur (car pl))+ (when (= cur n) (raise #t))+ (when (zero? (remainder n cur)) (raise #f))+ (when (> (* cur cur) n) (raise #t)))))++; This computes the next prime past the end of the table and adds it+; to the table, until the size of the primes table is at least n.++(define (grow-primes-table n)+ (do ((j (length primes) (+ j 1)))+ ((>= (length primes) n) primes)+ (do ((i (+ 2 (last primes)) (+ 2 i)))+ ((is-prime? i) (set! primes (append primes (list i)))))))++; This computes the sum of the reciprocals of the first n primes.+; It makes use of the fact that the (gro-primes-table) routine above+; returns the list of primes after it has finished growing it.++(define (sum-recprimes n)+ (apply + (map / (list-head (grow-primes-table n) n))))
+ selftest.scm view
@@ -0,0 +1,2636 @@+; Copyright 2008 Uwe Hollerbach <uh@alumni.caltech.edu>++; This file is part of haskeem.+; haskeem is free software; you can redistribute it and/or modify+; it under the terms of the GNU General Public License as published by+; the Free Software Foundation; either version 2 of the License, or+; (at your option) any later version.++; haskeem is distributed in the hope that it will be useful,+; but WITHOUT ANY WARRANTY; without even the implied warranty of+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+; GNU General Public License for more details.++; You should have received a copy of the GNU General Public License+; along with haskeem; if not, write to the Free Software+; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA++; $Id: selftest.scm,v 1.38 2009-05-30 04:52:00 uwe Exp $++(define start (epochtime))++(define verbose? #f)++(when (and (positive? (length args)) (string=? (car args) "-v"))+ (set! verbose? #t)+ (set! args (cdr args)))++(write-string "Some simple self-tests for haskeem" #\linefeed #\linefeed)++; first define the function to run the tests, plus counters++(define n-tests 0)+(define n-fails 0)++; this was originally named assert, but R6RS claims that as a syntactic form++(define (chk-closeto cmp expect expr)+ (set! n-tests (+ n-tests 1))+ (let* ((got (eval expr))+ (show-details (lambda ()+ (write-string "test "+ (number->string n-tests)+ ": evaluating ")+ (display expr)+ (write-string "\nexpecting ")+ (display expect)+ (write-string "\ngot ")+ (display got))))+ (when verbose? (show-details))+ (if (cmp expect got)+ (when verbose? (write-string " ok!\n\n"))+ (begin (unless verbose? (show-details))+ (write-string " FAILED!\n\n")+ (set! n-fails (+ n-fails 1))))))++(define (chk-run expect expr) (chk-closeto eqv? expect expr))++(define (rel-tol x y)+ (when verbose? + (write-string "\nrel diff " (number->string (abs (- x y)))))+ (< (abs (- x y)) (* (* 0.5 (+ (abs x) (abs y))) 1.25e-15)))++(define (abs-tol x y)+ (when verbose?+ (write-string "\nabs diff " (number->string (abs (- x y)))))+ (< (abs (- x y)) 1.25e-15))++(define (get-user-response)+ (let ((ans (list-drop-while char-whitespace? (string->char (read-line)))))+ (cond ((= 0 (length ans)) #t)+ ((char=? #\y (char-downcase (car ans))) #t)+ (else #f))))++(define (maybe expect got)+ (unless verbose?+ (write-string "expecting to see " expect ", got ")+ (display got))+ (write-string "\nis that reasonable? ")+ (flush-port stdout)+ (if verbose?+ (get-user-response)+ (begin (write-string "[assuming yes]\n") #t)))++(define (chk-query expect expr) (chk-closeto maybe expect expr))++; test the chk-run function itself: this should fail++(write-string "checking chk-run... expect a failure message here\n")+(chk-run #f '1)+(if (zero? n-fails)+ (begin (write-string "uh-oh! chk-run didn't record failure,"+ " better check that!\n\n")+ (set! n-fails 1))+ (begin (write-string "ok, zeroing out n-fails so this"+ " won't be recorded as a failure\n\n")+ (set! n-fails 0)))++; now do real tests++(chk-run 1 '1)+(chk-run 0 '(+))+(chk-run 2 '(+ 2))++(chk-run 1 '(*))+(chk-run 2 '(* 2))++(chk-run 5 '(+ 2 3))+(chk-run 2 '(+ 1 1))+(chk-run 3 '(+ 1 1 1))+(chk-run 4 '(+ 1 1 1 1))+(chk-run 5 '(+ 1 1 1 1 1))+(chk-run #f '(even? 3))+(chk-run 65536 '(* 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2))+(chk-run 11 '(+ 1 (* 2 3) (gcd 8 12)))++(chk-run 11 '(- 5 4 -2 3 -11))+(chk-run 163 '(+ 1 (* 2 (expt 3 4))))++(chk-run 1267650600228229401496703205376 '(expt 2 100))++(chk-run +nan.0 '(sqrt -1.0))+(chk-run +nan.0 -nan.0)+(chk-run +inf.0 '(expt 1.0e99 1.0e99))+(chk-run -inf.0 '(log 0.0))+(chk-run +nan.0 '(+ +inf.0 -inf.0))+(chk-run +inf.0 '(+ +inf.0 1.0e99))+(chk-run +inf.0 '(- +inf.0 1.0e99))+(chk-run +inf.0 '(* +inf.0 1.0e99))+(chk-run +inf.0 '(/ +inf.0 1.0e99))++(chk-run 4 '(modulo 30 13))+(chk-run 9 '(modulo -30 13))+(chk-run -9 '(modulo 30 -13))+(chk-run -4 '(modulo -30 -13))++(chk-run 4 '(remainder 30 13))+(chk-run -4 '(remainder -30 13))+(chk-run 4 '(remainder 30 -13))+(chk-run -4 '(remainder -30 -13))++(chk-run 5 '(max 1 3 5 2 -17))+(chk-run -17 '(min 1 3 5 2 -17))++(chk-run 5 '(max 5))+(chk-run -17 '(min -17))++(chk-run 1 '(gcd 3 9 7))+(chk-run 1 '(gcd 582162 28906206 3064173 28894803 8519281 28657487+ 16218068 27093208 17492496 26590452 18289922 26224366))+(chk-run 6 '(lcm 2 3 6))+(chk-run 18 '(lcm 2 6 9))++; check candidate taxicab number Ta(6)+(define (cube x) (* x x x))+(chk-run 24153319581254312065344 '(+ (cube 582162) (cube 28906206)))+(chk-run 24153319581254312065344 '(+ (cube 3064173) (cube 28894803)))+(chk-run 24153319581254312065344 '(+ (cube 8519281) (cube 28657487)))+(chk-run 24153319581254312065344 '(+ (cube 16218068) (cube 27093208)))+(chk-run 24153319581254312065344 '(+ (cube 17492496) (cube 26590452)))+(chk-run 24153319581254312065344 '(+ (cube 18289922) (cube 26224366)))++(define (self-test-fn1 op x y) (op x y))+(chk-run 65 '(self-test-fn1 + 23 42))+(chk-run 966 '(self-test-fn1 * 23 42))++(chk-run #t '(number? 1))+(chk-run #t '(number? 1.0))+(chk-run #t '(number? 1/3))+(chk-run #f '(number? 'a))+(chk-run #f '(number? '()))++(chk-run #t '(integer? 1))+(chk-run #f '(integer? 1.0))+(chk-run #f '(integer? 1/3))+(chk-run #f '(integer? 'a))+(chk-run #f '(integer? '()))++(chk-run #t '(rational? 1))+(chk-run #t '(rational? 1/4))+(chk-run #f '(rational? 1.4))+(chk-run #f '(rational? 'a))+(chk-run #f '(rational? '()))++(chk-run #t '(real? 1))+(chk-run #t '(real? 1/4))+(chk-run #t '(real? 1.4))+(chk-run #f '(real? 'a))+(chk-run #f '(real? '()))++(chk-run #t '(number? +nan.0))+(chk-run #t '(number? 0/0))+(chk-run #t '(real? +nan.0))+(chk-run #f '(rational? +nan.0))+(chk-run #t '(real? 0/0))+(chk-run #t '(rational? 0/0))++(chk-run #t '(number? +inf.0))+(chk-run #t '(number? 1/0))+(chk-run #t '(real? +inf.0))+(chk-run #f '(rational? +inf.0))+(chk-run #t '(real? 1/0))+(chk-run #t '(rational? 1/0))++(chk-run #f '(positive? -inf.0))+(chk-run #f '(positive? -1/0))+(chk-run #f '(positive? -1))+(chk-run #f '(positive? -1.0))+(chk-run #f '(positive? -1/2))++(chk-run #f '(positive? +nan.0))+(chk-run #f '(positive? 0/0))+(chk-run #f '(positive? 0))+(chk-run #f '(positive? 0.0))+(chk-run #f '(positive? 0/2))+(chk-run #f '(positive? 'a))+(chk-run #f '(positive? '(1 2 3)))++(chk-run #t '(positive? +inf.0))+(chk-run #t '(positive? 1/0))+(chk-run #t '(positive? 1))+(chk-run #t '(positive? 1.0))+(chk-run #t '(positive? 1/2))++(chk-run #t '(negative? -inf.0))+(chk-run #t '(negative? -1/0))+(chk-run #t '(negative? -1))+(chk-run #t '(negative? -1.0))+(chk-run #t '(negative? -1/2))++(chk-run #f '(negative? +nan.0))+(chk-run #f '(negative? 0/0))+(chk-run #f '(negative? 0))+(chk-run #f '(negative? 0.0))+(chk-run #f '(negative? 0/2))+(chk-run #f '(negative? 'a))+(chk-run #f '(negative? '(1 2 3)))++(chk-run #f '(negative? +inf.0))+(chk-run #f '(negative? 1/0))+(chk-run #f '(negative? 1))+(chk-run #f '(negative? 1.0))+(chk-run #f '(negative? 1/2))++(chk-run #f '(zero? -inf.0))+(chk-run #f '(zero? -1/0))+(chk-run #f '(zero? -1))+(chk-run #f '(zero? -1.0))+(chk-run #f '(zero? -1/2))++(chk-run #f '(zero? +nan.0))+(chk-run #f '(zero? 0/0))+(chk-run #t '(zero? 0))+(chk-run #t '(zero? 0.0))+(chk-run #t '(zero? 0/2))+(chk-run #f '(zero? 'a))+(chk-run #f '(zero? '(1 2 3)))++(chk-run #f '(zero? +inf.0))+(chk-run #f '(zero? 1/0))+(chk-run #f '(zero? 1))+(chk-run #f '(zero? 1.0))+(chk-run #f '(zero? 1/2))++(chk-run #t '(symbol? '+))+(chk-run #t '(symbol? 'a))+(chk-run #t '(symbol? 'zippyfoo123_?))+(chk-run #f '(symbol? '()))+(chk-run #f '(symbol? 4))+(chk-run #f '(symbol? '(a b c)))++(chk-run #t '(pair? '(a . b)))+(chk-run #t '(pair? '(a b c)))+(chk-run #f '(pair? '()))+(chk-run #f '(pair? 'a))+(chk-run #f '(pair? 4))+(chk-run #f '(pair? #t))++(chk-run #f '(list? '(a . b)))+(chk-run #t '(list? '(a b c)))+(chk-run #t '(list? '()))+(chk-run #f '(list? 'a))+(chk-run #f '(list? 4))+(chk-run #f '(list? #t))++(chk-run #f '(string=? "lesser" "greater"))+(chk-run #f '(string<? "lesser" "greater"))+(chk-run #t '(string>? "lesser" "greater"))+(chk-run #t '(string>=? "lesser" "greater"))+(chk-run #f '(string<=? "lesser" "greater"))++(chk-run #t '(string<? "greater" "lesser"))+(chk-run #f '(string>? "greater" "lesser"))+(chk-run #f '(string>=? "greater" "lesser"))+(chk-run #t '(string<=? "greater" "lesser"))++(chk-run #t '(string=? "lesser" "lesser"))+(chk-run #f '(string<? "lesser" "lesser"))+(chk-run #f '(string>? "lesser" "lesser"))+(chk-run #t '(string>=? "lesser" "lesser"))+(chk-run #t '(string<=? "lesser" "lesser"))++(define p3 (curry + 3))+(define m3 (curry * 3))+(define m3p3 (compose m3 p3))++(chk-run 3 '(p3))+(chk-run 5 '(p3 2))+(chk-run 10 '(p3 2 5))+(chk-run 9 '(p3 2 5 -1))++(chk-run 9 '(m3p3))+(chk-run 15 '(m3p3 2))+(chk-run 21 '(m3p3 1 3))++; TODO: check a bunch more of these++; ("/", lispDiv),+; ("quotient", integerBinop "quotient" quot),+; ("boolean?", isBool),+; ("string?", isString),+; ("char?", isChar),+; ("port?", isPort),+; ("char=?", charBoolBinop "char=?" (==)),+; ("char<?", charBoolBinop "char<?" (<)),+; ("char>?", charBoolBinop "char>?" (>)),+; ("char>=?", charBoolBinop "char>=?" (>=)),+; ("char<=?", charBoolBinop "char<=?" (<=)),+; ("char-alphabetic?", charIs isAlpha),+; ("char-numeric?", charIs isDigit),+; ("char-oct-digit?", charIs isOctDigit),+; ("char-hex-digit?", charIs isHexDigit),+; ("char-whitespace?", charIs isSpace),+; ("char-upper-case?", charIs isUpper),+; ("char-lower-case?", charIs isLower),+; ("char-alphanumeric?", charIs isAlphaNum),+; ("char-control?", charIs isControl),+; ("char-printable?", charIs isPrint),+; ("eqv?", eqv),+; ("char->integer", char2int),+; ("integer->char", int2char),++(chk-run 69 '(expmod 3 21 77))+(chk-run 43 '(expmod 17 125000 211))++(chk-run #t '(mersenne-prime? 2))+(chk-run #t '(mersenne-prime? 3))+(chk-run #t '(mersenne-prime? 5))+(chk-run #t '(mersenne-prime? 7))++(chk-run #t '(mersenne-prime? 13))+(chk-run #t '(mersenne-prime? 17))+(chk-run #t '(mersenne-prime? 19))++(chk-run #t '(mersenne-prime? 31))+(chk-run #t '(mersenne-prime? 61))+(chk-run #t '(mersenne-prime? 89))+(chk-run #t '(mersenne-prime? 107))+(chk-run #t '(mersenne-prime? 127))+(chk-run #t '(mersenne-prime? 521))+(chk-run #t '(mersenne-prime? 607))++(chk-run #f '(mersenne-prime? 11))+(chk-run #f '(mersenne-prime? 23))+(chk-run #f '(mersenne-prime? 29))++(chk-run #t '(mersenne-prime? 4423))++(chk-closeto rel-tol -0.1411200080598672221 '(sin -3))+(chk-closeto rel-tol -0.9092974268256816954 '(sin -2))+(chk-closeto rel-tol -0.84147098480789650665 '(sin -1))+(chk-closeto abs-tol 0.0 '(sin 0))+(chk-closeto rel-tol 0.84147098480789650665 '(sin 1))+(chk-closeto rel-tol 0.9092974268256816954 '(sin 2))+(chk-closeto rel-tol 0.1411200080598672221 '(sin 3))++(chk-closeto rel-tol -1.11976951499863418669 '(asin -0.9))+(chk-closeto rel-tol -0.92729521800161223243 '(asin -0.8))+(chk-closeto rel-tol -0.77539749661075306374 '(asin -0.7))+(chk-closeto rel-tol -0.6435011087932843868 '(asin -0.6))+(chk-closeto rel-tol -0.52359877559829887308 '(asin -0.5))+(chk-closeto rel-tol -0.41151684606748801939 '(asin -0.4))+(chk-closeto rel-tol -0.30469265401539750797 '(asin -0.3))+(chk-closeto rel-tol -0.20135792079033079145 '(asin -0.2))+(chk-closeto rel-tol -0.10016742116155979635 '(asin -0.1))+(chk-closeto abs-tol 0.0 '(asin 0))+(chk-closeto rel-tol 0.10016742116155979635 '(asin 0.1))+(chk-closeto rel-tol 0.20135792079033079145 '(asin 0.2))+(chk-closeto rel-tol 0.30469265401539750797 '(asin 0.3))+(chk-closeto rel-tol 0.41151684606748801939 '(asin 0.4))+(chk-closeto rel-tol 0.52359877559829887308 '(asin 0.5))+(chk-closeto rel-tol 0.6435011087932843868 '(asin 0.6))+(chk-closeto rel-tol 0.77539749661075306374 '(asin 0.7))+(chk-closeto rel-tol 0.92729521800161223243 '(asin 0.8))+(chk-closeto rel-tol 1.11976951499863418669 '(asin 0.9))++(chk-closeto rel-tol -0.98999249660044545727 '(cos -3))+(chk-closeto rel-tol -0.416146836547142387 '(cos -2))+(chk-closeto rel-tol 0.5403023058681397174 '(cos -1))+(chk-closeto rel-tol 1.0 '(cos 0))+(chk-closeto rel-tol 0.5403023058681397174 '(cos 1))+(chk-closeto rel-tol -0.416146836547142387 '(cos 2))+(chk-closeto rel-tol -0.98999249660044545727 '(cos 3))++(chk-closeto rel-tol 2.69056584179353080592 '(acos -0.9))+(chk-closeto rel-tol 2.49809154479650885166 '(acos -0.8))+(chk-closeto rel-tol 2.34619382340564968297 '(acos -0.7))+(chk-closeto rel-tol 2.21429743558818100603 '(acos -0.6))+(chk-closeto rel-tol 2.09439510239319549231 '(acos -0.5))+(chk-closeto rel-tol 1.98231317286238463862 '(acos -0.4))+(chk-closeto rel-tol 1.8754889808102941272 '(acos -0.3))+(chk-closeto rel-tol 1.77215424758522741069 '(acos -0.2))+(chk-closeto rel-tol 1.67096374795645641558 '(acos -0.1))+(chk-closeto rel-tol 1.57079632679489661923 '(acos 0))+(chk-closeto rel-tol 1.47062890563333682289 '(acos 0.1))+(chk-closeto rel-tol 1.36943840600456582778 '(acos 0.2))+(chk-closeto rel-tol 1.26610367277949911126 '(acos 0.3))+(chk-closeto rel-tol 1.15927948072740859985 '(acos 0.4))+(chk-closeto rel-tol 1.04719755119659774615 '(acos 0.5))+(chk-closeto rel-tol 0.92729521800161223243 '(acos 0.6))+(chk-closeto rel-tol 0.79539883018414355549 '(acos 0.7))+(chk-closeto rel-tol 0.6435011087932843868 '(acos 0.8))+(chk-closeto rel-tol 0.45102681179626243255 '(acos 0.9))++(chk-closeto rel-tol 0.1425465430742778053 '(tan -3))+(chk-closeto rel-tol 2.18503986326151899164 '(tan -2))+(chk-closeto rel-tol -1.55740772465490223051 '(tan -1))+(chk-closeto abs-tol 0.0 '(tan 0))+(chk-closeto rel-tol 1.55740772465490223051 '(tan 1))+(chk-closeto rel-tol -2.18503986326151899164 '(tan 2))+(chk-closeto rel-tol -0.1425465430742778053 '(tan 3))++(chk-closeto rel-tol -0.73281510178650659164 '(atan -0.9))+(chk-closeto rel-tol -0.67474094222355266306 '(atan -0.8))+(chk-closeto rel-tol -0.61072596438920861654 '(atan -0.7))+(chk-closeto rel-tol -0.54041950027058415544 '(atan -0.6))+(chk-closeto rel-tol -0.46364760900080611621 '(atan -0.5))+(chk-closeto rel-tol -0.3805063771123648863 '(atan -0.4))+(chk-closeto rel-tol -0.291456794477867092 '(atan -0.3))+(chk-closeto rel-tol -0.19739555984988075837 '(atan -0.2))+(chk-closeto rel-tol -0.09966865249116202738 '(atan -0.1))+(chk-closeto abs-tol 0.0 '(atan 0))+(chk-closeto rel-tol 0.09966865249116202738 '(atan 0.1))+(chk-closeto rel-tol 0.19739555984988075837 '(atan 0.2))+(chk-closeto rel-tol 0.291456794477867092 '(atan 0.3))+(chk-closeto rel-tol 0.3805063771123648863 '(atan 0.4))+(chk-closeto rel-tol 0.46364760900080611621 '(atan 0.5))+(chk-closeto rel-tol 0.54041950027058415544 '(atan 0.6))+(chk-closeto rel-tol 0.61072596438920861654 '(atan 0.7))+(chk-closeto rel-tol 0.67474094222355266306 '(atan 0.8))+(chk-closeto rel-tol 0.73281510178650659164 '(atan 0.9))++(chk-closeto rel-tol -10.01787492740990189897 '(sinh -3))+(chk-closeto rel-tol -3.62686040784701876767 '(sinh -2))+(chk-closeto rel-tol -1.17520119364380145688 '(sinh -1))+(chk-closeto abs-tol 0.0 '(sinh 0))+(chk-closeto rel-tol 1.17520119364380145688 '(sinh 1))+(chk-closeto rel-tol 3.62686040784701876767 '(sinh 2))+(chk-closeto rel-tol 10.01787492740990189897 '(sinh 3))++(chk-closeto rel-tol -0.80886693565278246251 '(asinh -0.9))+(chk-closeto rel-tol -0.73266825604541086415 '(asinh -0.8))+(chk-closeto rel-tol -0.65266656608235578681 '(asinh -0.7))+(chk-closeto rel-tol -0.5688248987322475301 '(asinh -0.6))+(chk-closeto rel-tol -0.4812118250596034475 '(asinh -0.5))+(chk-closeto rel-tol -0.39003531977071527608 '(asinh -0.4))+(chk-closeto rel-tol -0.2956730475634224391 '(asinh -0.3))+(chk-closeto rel-tol -0.19869011034924140647 '(asinh -0.2))+(chk-closeto rel-tol -0.09983407889920756333 '(asinh -0.1))+(chk-closeto abs-tol 0 '(asinh 0))+(chk-closeto rel-tol 0.09983407889920756333 '(asinh 0.1))+(chk-closeto rel-tol 0.19869011034924140647 '(asinh 0.2))+(chk-closeto rel-tol 0.2956730475634224391 '(asinh 0.3))+(chk-closeto rel-tol 0.39003531977071527608 '(asinh 0.4))+(chk-closeto rel-tol 0.4812118250596034475 '(asinh 0.5))+(chk-closeto rel-tol 0.5688248987322475301 '(asinh 0.6))+(chk-closeto rel-tol 0.65266656608235578681 '(asinh 0.7))+(chk-closeto rel-tol 0.73266825604541086415 '(asinh 0.8))+(chk-closeto rel-tol 0.80886693565278246251 '(asinh 0.9))++(chk-closeto rel-tol 10.06766199577776584195 '(cosh -3))+(chk-closeto rel-tol 3.76219569108363145956 '(cosh -2))+(chk-closeto rel-tol 1.54308063481524377848 '(cosh -1))+(chk-closeto rel-tol 1.0 '(cosh 0))+(chk-closeto rel-tol 1.54308063481524377848 '(cosh 1))+(chk-closeto rel-tol 3.76219569108363145956 '(cosh 2))+(chk-closeto rel-tol 10.06766199577776584195 '(cosh 3))++(chk-closeto rel-tol 0.44356825438511518913 '(acosh 1.1))+(chk-closeto rel-tol 0.62236250371477866781 '(acosh 1.2))+(chk-closeto rel-tol 0.75643291085695958624 '(acosh 1.3))+(chk-closeto rel-tol 0.86701472649056510395 '(acosh 1.4))+(chk-closeto rel-tol 0.962423650119206895 '(acosh 1.5))+(chk-closeto rel-tol 1.04696791500318841107 '(acosh 1.6))+(chk-closeto rel-tol 1.12323098258729588953 '(acosh 1.7))+(chk-closeto rel-tol 1.19291073099304900366 '(acosh 1.8))+(chk-closeto rel-tol 1.25719582660038043454 '(acosh 1.9))+(chk-closeto rel-tol 1.31695789692481670862 '(acosh 2))+(chk-closeto rel-tol 1.37285914424257984048 '(acosh 2.1))+(chk-closeto rel-tol 1.42541694307061258385 '(acosh 2.2))+(chk-closeto rel-tol 1.47504478124142507995 '(acosh 2.3))+(chk-closeto rel-tol 1.52207936746365331526 '(acosh 2.4))+(chk-closeto rel-tol 1.56679923697241107866 '(acosh 2.5))++(chk-closeto rel-tol -0.99505475368673045133 '(tanh -3))+(chk-closeto rel-tol -0.96402758007581688395 '(tanh -2))+(chk-closeto rel-tol -0.76159415595576488812 '(tanh -1))+(chk-closeto abs-tol 0.0 '(tanh 0))+(chk-closeto rel-tol 0.76159415595576488812 '(tanh 1))+(chk-closeto rel-tol 0.96402758007581688395 '(tanh 2))+(chk-closeto rel-tol 0.99505475368673045133 '(tanh 3))++(chk-closeto rel-tol -1.47221948958322023 '(atanh -0.9))+(chk-closeto rel-tol -1.0986122886681096914 '(atanh -0.8))+(chk-closeto rel-tol -0.86730052769405319443 '(atanh -0.7))+(chk-closeto rel-tol -0.69314718055994530942 '(atanh -0.6))+(chk-closeto rel-tol -0.5493061443340548457 '(atanh -0.5))+(chk-closeto rel-tol -0.42364893019360180686 '(atanh -0.4))+(chk-closeto rel-tol -0.30951960420311171547 '(atanh -0.3))+(chk-closeto rel-tol -0.20273255405408219099 '(atanh -0.2))+(chk-closeto rel-tol -0.10033534773107558064 '(atanh -0.1))+(chk-closeto abs-tol 0.0 '(atanh 0))+(chk-closeto rel-tol 0.10033534773107558064 '(atanh 0.1))+(chk-closeto rel-tol 0.20273255405408219099 '(atanh 0.2))+(chk-closeto rel-tol 0.30951960420311171547 '(atanh 0.3))+(chk-closeto rel-tol 0.42364893019360180686 '(atanh 0.4))+(chk-closeto rel-tol 0.5493061443340548457 '(atanh 0.5))+(chk-closeto rel-tol 0.69314718055994530942 '(atanh 0.6))+(chk-closeto rel-tol 0.86730052769405319443 '(atanh 0.7))+(chk-closeto rel-tol 1.0986122886681096914 '(atanh 0.8))+(chk-closeto rel-tol 1.47221948958322023 '(atanh 0.9))++(chk-closeto rel-tol 0.00247875217666635842 '(exp -6))+(chk-closeto rel-tol 0.0067379469990854671 '(exp -5))+(chk-closeto rel-tol 0.01831563888873418029 '(exp -4))+(chk-closeto rel-tol 0.04978706836786394298 '(exp -3))+(chk-closeto rel-tol 0.13533528323661269189 '(exp -2))+(chk-closeto rel-tol 0.3678794411714423216 '(exp -1))+(chk-closeto rel-tol 1 '(exp 0))+(chk-closeto rel-tol 2.71828182845904523536 '(exp 1))+(chk-closeto rel-tol 7.38905609893065022723 '(exp 2))+(chk-closeto rel-tol 20.08553692318766774093 '(exp 3))+(chk-closeto rel-tol 54.59815003314423907811 '(exp 4))+(chk-closeto rel-tol 148.41315910257660342111 '(exp 5))+(chk-closeto rel-tol 403.42879349273512260839 '(exp 6))++(chk-closeto rel-tol -2.30258509299404568402 '(log 0.1))+(chk-closeto rel-tol 0.09531017980432486004 '(log 1.1))+(chk-closeto rel-tol 0.74193734472937731248 '(log 2.1))+(chk-closeto rel-tol 1.13140211149110056191 '(log 3.1))+(chk-closeto rel-tol 1.41098697371026211985 '(log 4.1))+(chk-closeto rel-tol 1.62924053973028008763 '(log 5.1))++(chk-closeto rel-tol 1.0 '(sin (* pi 0.5)))+(chk-closeto abs-tol 0.0 '(cos (* pi 0.5)))+(chk-closeto rel-tol (/ pi 4.0) '(atan 1.0))+(chk-closeto rel-tol 10.0 '(sqrt 1.0e2))+(chk-closeto rel-tol 0.3333 '(exp (log 0.3333)))+(chk-closeto rel-tol 171.411373 '(exp (log 171.411373)))+(chk-closeto rel-tol 0.4753882 '(tan (atan 0.4753882)))+(chk-closeto abs-tol 1.0+ '(let* ((x 0.4332758)+ (s (sin x))+ (c (cos x)))+ (+ (* s s) (* c c))))+(chk-closeto abs-tol 1.0+ '(let* ((x 14.123456579)+ (s (sin x))+ (c (cos x)))+ (+ (* s s) (* c c))))++(chk-run 14 '(round 14.33))+(chk-run 15 '(round 14.53))+(chk-run 14 '(round 14.5))+(chk-run 14 '(floor 14.2))+(chk-run 14 '(floor 14.999))+(chk-run -15 '(floor -14.2))+(chk-run 15 '(ceiling 14.999))+(chk-run -14 '(ceiling -14.2))+(chk-run 14 '(truncate 14.2))+(chk-run -14 '(truncate -14.2))++(chk-run 566667/10000 '(round 170/3 10 4))+(chk-run 56667/1000 '(round 170/3 10 3))+(chk-run 5667/100 '(round 170/3 10 2))+(chk-run 567/10 '(round 170/3 10 1))+(chk-run 57 '(round 170/3 10 0))+(chk-run 60 '(round 170/3 10 -1))+(chk-run 100 '(round 170/3 10 -2))+(chk-run 0 '(round 170/3 10 -4))++(chk-run 56.6667 '(round 56.666666666666666 10 4))+(chk-run 56.667 '(round 56.666666666666666 10 3))+(chk-run 56.67 '(round 56.666666666666666 10 2))+(chk-run 56.7 '(round 56.666666666666666 10 1))+(chk-run 57 '(round 56.666666666666666 10 0))+(chk-run 60 '(round 56.666666666666666 10 -1))+(chk-run 100 '(round 56.666666666666666 10 -2))+(chk-run 0 '(round 56.666666666666666 10 -3))++(chk-closeto rel-tol 0.1233456677 '(cos (acos 0.1233456677)))+(chk-closeto rel-tol 0.4753882 '(sin (asin 0.4753882)))++(chk-run '(a 7 c) '(list 'a (+ 3 4) 'c))+(chk-run '() '(list))+(chk-run 3 '(length '(a b c)))+(chk-run 3 '(length '(a (b) (c d e))))+(chk-run 0 '(length '()))++(chk-run '(a . b) '(cons 'a 'b))+(chk-run '(a b c) '(list 'a 'b 'c))+(chk-run '(a b c) '(cons 'a (cons 'b (cons 'c '()))))+(chk-run '(a b c) '(id '(a . (b . (c . ())))))+(chk-run 'a '(car '(a . (b . (c . ())))))+(chk-run '(b c) '(cdr '(a . (b . (c . ())))))+(chk-run 'b '(cadr '(a . (b . (c . ())))))++(chk-run '(b e h) '(map cadr '((a b) (d e) (g h))))+(chk-run '(1 4 27 256 3125) '(map (lambda (n) (expt n n)) '(1 2 3 4 5)))++; R6RS says this can produce either '(1 2) or '(2 1); it basically returns+; the order in which map processes the contents of its list argument, which+; for haskeem is (1 2)++(chk-run '(1 2) '(let ((count 0))+ (map (lambda (ignored)+ (set! count (+ count 1))+ count)+ '(a b))))++(chk-run '(6 8 10 12) '(map + '(1 2 3 4) '(5 6 7 8)))++(chk-run -1 '((flip -) 2 1))++(chk-run 10 '(foldr + 0 '(1 2 3 4)))+(chk-run 10 '(foldl + 0 '(1 2 3 4)))++; test conditionals 'if', 'cond', 'when', and 'unless'++(define cond-test-expr '(cond ((= cond-test-var 1) 'foo)+ ((= cond-test-var 2) 'bar)+ ((= cond-test-var 3) 'baz)+ (else 'quux)))+(define if-test-expr+ '(if (= cond-test-var 1)+ 'foo (if (= cond-test-var 2)+ 'bar (if (= cond-test-var 3) 'baz 'quux))))+(define when-test-expr '(when (= cond-test-var 1) 'foo))+(define unless-test-expr '(unless (= cond-test-var 1) 'foo))++(define cond-test-var 1)+(chk-run 'foo cond-test-expr)+(chk-run 'foo if-test-expr)+(chk-run 'foo when-test-expr)+(chk-run #f unless-test-expr)+(define cond-test-var 2)+(chk-run 'bar cond-test-expr)+(chk-run 'bar if-test-expr)+(chk-run #f when-test-expr)+(chk-run 'foo unless-test-expr)+(define cond-test-var 3)+(chk-run 'baz cond-test-expr)+(chk-run 'baz if-test-expr)+(chk-run #f when-test-expr)+(chk-run 'foo unless-test-expr)+(define cond-test-var 4)+(chk-run 'quux cond-test-expr)+(chk-run 'quux if-test-expr)+(chk-run #f when-test-expr)+(chk-run 'foo unless-test-expr)++; and the alternate cond syntax with '=>'++(define cond-test-expr '(cond ((= cond-test-var 1) 0)+ ((= cond-test-var 2) 1)+ (cond-test-var => sin)))+(define cond-test-var 1)+(chk-run 0 cond-test-expr)+(define cond-test-var 2)+(chk-run 1 cond-test-expr)+(define cond-test-var 3)+(chk-closeto rel-tol 0.1411200080598672 cond-test-expr)+(define cond-test-var 4)+(chk-closeto rel-tol -0.7568024953079282 cond-test-expr)++; test conditionals 'and' and 'or'++; if (write-string) is reached, and failed++(chk-run #f '(and 1 'a '() #f (write-string "and failed!\n")))+(chk-run 'baloney '(and 1 'a 'baloney))++; if (write-string) is reached, or failed+(chk-run 'a '(or #f 'a 1 '() (write-string "or failed!\n")))+(chk-run #f '(or #f (= 1 0)))+(chk-run #f '(or #f (= 0 2) #f))++; test conditional 'case'; these are pretty directly from R6RS:++(define case-expr '(case case-val+ ((1) 'unit)+ ((2 3 5 7) 'prime)+ ((4 6 8 9 10 (* 6 2)) 'composite)))+(define case-val 1)+(chk-run 'unit case-expr)+(define case-val 2)+(chk-run 'prime case-expr)+(define case-val 3)+(chk-run 'prime case-expr)+(define case-val 4)+(chk-run 'composite case-expr)+(define case-val 5)+(chk-run 'prime case-expr)+(define case-val 6)+(chk-run 'composite case-expr)+(define case-val 7)+(chk-run 'prime case-expr)+(define case-val 8)+(chk-run 'composite case-expr)+(define case-val 9)+(chk-run 'composite case-expr)+(define case-val 10)+(chk-run 'composite case-expr)+(define case-val 11)+(chk-run #f case-expr)+(define case-val 12)+(chk-run #f case-expr)++(define case-val '(* 6 2))+(chk-run 'composite case-expr)++(chk-run #f '(case (car '(c d))+ ((a) 'a)+ ((b) 'b)))++(chk-run 'vowel '(case (car '(u d))+ ((a e i o u) 'vowel)+ ((w y) 'semivowel)+ (else 'consonant)))++; letXXX examples are pretty much directly from R6RS:++; test let form, including shadowing of variables:+; def'n of z sees outer value of x, then body sees inner value++(chk-run 35 '(let ((x 2) (y 3))+ (let ((x 7) (z (+ x y)))+ (* z x))))++(chk-run 42 '(let ((x 23)) (set! x 42) x))++; test let* form: this is almost the same as above, except that now+; the def'n of z should see the inner value of x rather than the outer++(chk-run 70 '(let ((x 2) (y 3))+ (let* ((x 7) (z (+ x y)))+ (* z x))))++; test letrec form: mutually-recursive procedures evo? and odo?++(chk-run #t '(letrec ((evo?+ (lambda (n)+ (if (zero? n)+ #t+ (odo? (- n 1)))))+ (odo?+ (lambda (n)+ (if (zero? n)+ #f+ (evo? (- n 1))))))+ (evo? 88)))++; test letrec*: mutually-recursive, plus prior variables accessible++(chk-run 5 '(letrec* ((p (lambda (x) (+ 1 (q (- x 1)))))+ (q (lambda (y) (if (zero? y) 0 (+ 1 (p (- y 1))))))+ (x (p 5))+ (y x))+ y))++; test named-let form++(chk-run '((6 1 3) (-5 -2)) '(let lupus ((numbers '(3 -2 1 6 -5))+ (nonneg '())+ (neg '()))+ (cond ((null? numbers) (list nonneg neg))+ ((>= (car numbers) 0)+ (lupus (cdr numbers)+ (cons (car numbers) nonneg)+ neg))+ ((< (car numbers) 0)+ (lupus (cdr numbers)+ nonneg+ (cons (car numbers) neg))))))++; test "do" syntactic form: this comes directly from R6RS++(chk-run 25 '(let ((x '(1 3 5 7 9)))+ (do ((x x (cdr x))+ (sum 0 (+ sum (car x))))+ ((null? x) sum))))++; and this version checks the (<variable> <init>) version, without the <step>++(chk-run 35 '(let ((x '(1 3 5 7 9)))+ (do ((x x (cdr x))+ (monkey 2)+ (sum 0 (+ sum monkey (car x))))+ ((null? x) sum))))++; test some list-manipulation functions++(chk-run '((1 a) (2 b) (3 c)) '(map list '(1 2 3) '(a b c)))+(chk-run '((1 2 3) (a b c)) '(unzip '((1 a) (2 b) (3 c))))++(chk-run '(5 7 9) '(map + '(1 2 3) '(4 5 6)))+(chk-run '(4 10 18) '(map * '(1 2 3) '(4 5 6)))++(chk-run '(0) '(replicate 0 1))+(chk-run '(0 0 0) '(replicate 0 3))+(chk-run '((1 2)) '(replicate '(1 2) 1))+(chk-run '((1 2) (1 2) (1 2)) '(replicate '(1 2) 3))+(chk-run '() '(replicate '(1 2) 0))+(chk-run '(0 1 2 3 4) '(upfrom 0 5))++(chk-run '(0 1 2 3 4) '(list-tabulate 5 id))+(chk-run '() '(list-tabulate 0 id))+(chk-run '(0 1 4 9 16) '(list-tabulate 5 (lambda (x) (* x x))))++(define lst '(1 2 7 9 3 4 4 6 -1 8 11 -24))++(chk-run 12 '(length lst))+(chk-run '() '(list-head lst -2))+(chk-run '() '(list-head lst 0))+(chk-run '(1 2 7 9 3) '(list-head lst 5))+(chk-run lst '(list-head lst 100))+(chk-run '(4 4 6 -1 8 11 -24) '(list-tail lst 5))+(chk-run lst '(list-tail lst -100))+(chk-run lst '(list-tail lst 0))+(chk-run '() '(list-tail lst 100))+(chk-run '(8 11 -24) '(list-unhead lst 3))+(chk-run '() '(list-unhead lst -10))+(chk-run '() '(list-unhead lst 0))+(chk-run lst '(list-unhead lst 100))+(chk-run '(1 2 7 9 3 4 4 6) '(list-untail lst 4))+(chk-run lst '(list-untail lst -100))+(chk-run '() '(list-untail lst 100))+(chk-run 1 '(list-ref lst -100))+(chk-run 1 '(list-ref lst 0))+(chk-run 9 '(list-ref lst 3))+(chk-run '() '(list-ref lst 100))+(chk-run lst '(list-unref lst -100))+(chk-run (cdr lst) '(list-unref lst 0))+(chk-run '(1 2 7 3 4 4 6 -1 8 11 -24) '(list-unref lst 3))+(chk-run lst '(list-unref lst 100))+(chk-run -24 '(last lst))++(chk-run '(x y) '(append '(x) '(y)))+(chk-run '(a b c d) '(append '(a) '(b c d)))+(chk-run '(a (b) (c)) '(append '(a (b)) '((c))))+(chk-run '(a b c . d) '(append '(a b) '(c . d)))+(chk-run 'a '(append '() 'a))++(chk-run '(c b a) '(reverse '(a b c)))+(chk-run '((e (f)) d (b c) a) '(reverse '(a (b c) d (e (f)))))++(chk-run lst '(append (list-head lst 5) (list-unhead lst 7)))+(chk-run '(1 2 3 4 5 6 7 8 9) '(append '(1 2 3) '(4 5) '(6 7) '(8 9)))+(chk-run '(-24 11 8 -1 6) '(reverse (list-unhead lst 5)))+(chk-run '(2 4 4 6 8 -24) '(filter even? lst))+(chk-run '(1 7 9 3 -1 11 -24)+ '(filter (lambda (x) (or (odd? x) (< x 0))) lst))+(chk-run '(3 5 15 19 7 9 9 13 -1 17 23 -47)+ '(map (lambda (x) (+ 1 (* 2 x))) lst))++(chk-run 4 '(find even? '(3 1 4 1 5 9)))+(chk-run #f '(find even? '(3 1 5 1 5 9)))++(chk-run '(4 1 5 9 2 6 5) '(memp even? '(3 1 4 1 5 9 2 6 5)))+(chk-run #f '(memp negative? '(3 1 4 1 5 9 2 6 5)))++(chk-run '(101 102) '(memv 101 '(100 101 102)))+(chk-run #f '(memv 99 '(100 101 102)))++(chk-run '(4 c) '(assp even? '((3 a) (1 b) (4 c))))+(chk-run '(3 a) '(assp odd? '((3 a) (1 b) (4 c))))+(chk-run #f '(assp zero? '((3 a) (1 b) (4 c))))++(chk-run '(4 c) '(assv 4 '((3 a) (1 b) (4 c))))+(chk-run '(3 a) '(assv 3 '((3 a) (1 b) (4 c))))+(chk-run '(1 b) '(assv 1 '((3 a) (1 b) (4 c))))+(chk-run #f '(assv 0 '((3 a) (1 b) (4 c))))++(chk-run '((4 2 6 8) (3 1 1 5 9 5 3 5 9))+ '(partition even? '(3 1 4 1 5 9 2 6 5 3 5 8 9)))++; sort in increasing order+(define (c1 x y) (< x y))+(chk-run '(-24 -1 1 2 3 4 4 6 7 8 9 11) '(list-sort c1 lst))++; sort in decreasing order (then reverse)+(define (c2 x y) (> x y))+(chk-run '(-24 -1 1 2 3 4 4 6 7 8 9 11) '(reverse (list-sort c2 lst)))++; expect first all odds, decreasing, then all evens, increasing:+; if both are even, use comparison function c1 -> increasing+; if both are odd, use c2 -> decreasing+; if one is odd and one is even, the odd comes first++(define (c3 x y)+ (define ex (even? x))+ (define ey (even? y))+ (cond ((and ex ey) (c1 x y))+ ((and (not ex) (not ey)) (c2 x y))+ ((and ex (not ey)) #f)+ ((and (not ex) ey) #t)+ (else (error "waaa"))))+(chk-run '(11 9 7 3 1 -1 -24 2 4 4 6 8) '(list-sort c3 lst))++; test stability of list-sort++(define lp '((1 a) (1 b) (2 a) (1 c) (3 b) (2 f) (1 d) (2 b)))+(define (c1p x y) (< (car x) (car y)))+(chk-run '((1 a) (1 b) (1 c) (1 d) (2 a) (2 f) (2 b) (3 b))+ '(list-sort c1p lp))++(chk-run '(#\N #\O #\W) '(char-upcase (list #\n #\o #\w)))+(chk-run '(#\N #\O #\W) '(char-upcase #\n #\o #\w))++(chk-run '#\I '(char-upcase #\i))+(chk-run '#\s '(char-downcase #\S))++(chk-run "doit" '(char->string #\d #\o #\i #\t))+(chk-run "right" '(char->string '(#\r #\i #\g #\h #\t)))++(chk-run '(#\t #\i #\m #\e) '(char-downcase (list #\T #\I #\M #\E)))+(chk-run '(#\t #\i #\m #\e) '(char-downcase #\T #\I #\M #\E))++(chk-run "NOW IS THE TIME!" '(string-upcase "now is the time!"))++(chk-run "it works, he said, in a small quiet voice"+ '(string-downcase "IT WORKS, He sAId, IN A sMall QUIET voIcE"))++(chk-run '(7 9 3 4 4 6 -1 8 11 -24)+ '(list-drop-while (lambda (v) (< v 5)) lst))++(chk-run '((1 2) (7 9 3 4 4 6 -1 8 11 -24))+ '(list-take-while (lambda (v) (< v 5)) lst))++(chk-run '("it" "works" "he" "said" "in" "a" "small" "quiet" "voice")+ '(string-split-by (lambda (c) (not (char-alphabetic? c)))+ "it works, he said, in a small quiet voice"))++(chk-run "now, is, the, time, for, all"+ '(string-join-by ", " (list "now" "is" "the" "time" "for" "all")))++(chk-run "now:is:the:time:for:all"+ '(string-join-by ":" "now" "is" "the" "time" "for" "all"))++(chk-run 3735928559 '(string->number "#xdeadbeef"))++; THIS IS AN EXTENSION OF R6RS!+; They only do decimal floating-point numbers... how boring!++(chk-run 2.220446049250313e-16 '(string->number "#b1.0e-110100"))++; and use that extension to probe the floating-point representation...+(chk-run #f '(= 1.0 (+ 1.0 #b1.0e-110100)))+(chk-run #t '(= 1.0 (+ 1.0 #b1.0e-110101)))++; pi in base-8 and base-16+(chk-run "#o3.1103755242102643e0" '(number->string pi 8))+(chk-run "#x3.243f6a8885a3x0" '(number->string pi 16))++; this generates the base-8 string representing pi, explodes it into+; individual digits, adds those up via foldr, and compares the result+; to pi... this is specific to base 8, because:+; in base-2, the exponent is 1 not 0, but we just clip it off+; in base-10, there is no "#d" at the head, so we clip off too much+; in base-16, the simplistic character->number conversion doesn't work++(chk-run pi '(+ 3.0 (/ (foldr (lambda (a b)+ (+ (string->number (char->string a))+ (/ b 8)))+ 0.0+ (list-untail+ (list-tail+ (string->char (number->string pi 8))+ 4) 2)) 8)))++; This tests a hack: I have "(define (eval x) (eval x))" in stdlib.scm,+; which looks quite idiotic (and, indeed, it is) but it works, because+; "eval" is currently a special form in haskeem: so (eval foo) works,+; but (map eval (list foo)) does not. I have to fix that...++(chk-run '(3 1.0 #\C) '(map eval '((+ 1 2) (sin (/ pi 2)) (integer->char 67))))++; check rational comparison operators++(define nan 0/0)+(define pinf 1/0)+(define ninf -1/0)+(define zero 0)+(define pos 1)+(define neg -1)++; check comparison operator =+(chk-run #f '(= nan nan))+(chk-run #f '(= nan ninf))+(chk-run #f '(= nan neg))+(chk-run #f '(= nan zero))+(chk-run #f '(= nan pos))+(chk-run #f '(= nan pinf))+(chk-run #f '(= ninf nan))+(chk-run #t '(= ninf ninf))+(chk-run #f '(= ninf neg))+(chk-run #f '(= ninf zero))+(chk-run #f '(= ninf pos))+(chk-run #f '(= ninf pinf))+(chk-run #f '(= neg nan))+(chk-run #f '(= neg ninf))+(chk-run #t '(= neg neg))+(chk-run #f '(= neg zero))+(chk-run #f '(= neg pos))+(chk-run #f '(= neg pinf))+(chk-run #f '(= zero nan))+(chk-run #f '(= zero ninf))+(chk-run #f '(= zero neg))+(chk-run #t '(= zero zero))+(chk-run #f '(= zero pos))+(chk-run #f '(= zero pinf))+(chk-run #f '(= pos nan))+(chk-run #f '(= pos ninf))+(chk-run #f '(= pos neg))+(chk-run #f '(= pos zero))+(chk-run #t '(= pos pos))+(chk-run #f '(= pos pinf))+(chk-run #f '(= pinf nan))+(chk-run #f '(= pinf ninf))+(chk-run #f '(= pinf neg))+(chk-run #f '(= pinf zero))+(chk-run #f '(= pinf pos))+(chk-run #t '(= pinf pinf))++; check comparison operator /=+(chk-run #t '(/= nan nan))+(chk-run #t '(/= nan ninf))+(chk-run #t '(/= nan neg))+(chk-run #t '(/= nan zero))+(chk-run #t '(/= nan pos))+(chk-run #t '(/= nan pinf))+(chk-run #t '(/= ninf nan))+(chk-run #f '(/= ninf ninf))+(chk-run #t '(/= ninf neg))+(chk-run #t '(/= ninf zero))+(chk-run #t '(/= ninf pos))+(chk-run #t '(/= ninf pinf))+(chk-run #t '(/= neg nan))+(chk-run #t '(/= neg ninf))+(chk-run #f '(/= neg neg))+(chk-run #t '(/= neg zero))+(chk-run #t '(/= neg pos))+(chk-run #t '(/= neg pinf))+(chk-run #t '(/= zero nan))+(chk-run #t '(/= zero ninf))+(chk-run #t '(/= zero neg))+(chk-run #f '(/= zero zero))+(chk-run #t '(/= zero pos))+(chk-run #t '(/= zero pinf))+(chk-run #t '(/= pos nan))+(chk-run #t '(/= pos ninf))+(chk-run #t '(/= pos neg))+(chk-run #t '(/= pos zero))+(chk-run #f '(/= pos pos))+(chk-run #t '(/= pos pinf))+(chk-run #t '(/= pinf nan))+(chk-run #t '(/= pinf ninf))+(chk-run #t '(/= pinf neg))+(chk-run #t '(/= pinf zero))+(chk-run #t '(/= pinf pos))+(chk-run #f '(/= pinf pinf))++; check comparison operator <+(chk-run #f '(< nan nan))+(chk-run #f '(< nan ninf))+(chk-run #f '(< nan neg))+(chk-run #f '(< nan zero))+(chk-run #f '(< nan pos))+(chk-run #f '(< nan pinf))+(chk-run #f '(< ninf nan))+(chk-run #f '(< ninf ninf))+(chk-run #t '(< ninf neg))+(chk-run #t '(< ninf zero))+(chk-run #t '(< ninf pos))+(chk-run #t '(< ninf pinf))+(chk-run #f '(< neg nan))+(chk-run #f '(< neg ninf))+(chk-run #f '(< neg neg))+(chk-run #t '(< neg zero))+(chk-run #t '(< neg pos))+(chk-run #t '(< neg pinf))+(chk-run #f '(< zero nan))+(chk-run #f '(< zero ninf))+(chk-run #f '(< zero neg))+(chk-run #f '(< zero zero))+(chk-run #t '(< zero pos))+(chk-run #t '(< zero pinf))+(chk-run #f '(< pos nan))+(chk-run #f '(< pos ninf))+(chk-run #f '(< pos neg))+(chk-run #f '(< pos zero))+(chk-run #f '(< pos pos))+(chk-run #t '(< pos pinf))+(chk-run #f '(< pinf nan))+(chk-run #f '(< pinf ninf))+(chk-run #f '(< pinf neg))+(chk-run #f '(< pinf zero))+(chk-run #f '(< pinf pos))+(chk-run #f '(< pinf pinf))++; check comparison operator >+(chk-run #f '(> nan nan))+(chk-run #f '(> nan ninf))+(chk-run #f '(> nan neg))+(chk-run #f '(> nan zero))+(chk-run #f '(> nan pos))+(chk-run #f '(> nan pinf))+(chk-run #f '(> ninf nan))+(chk-run #f '(> ninf ninf))+(chk-run #f '(> ninf neg))+(chk-run #f '(> ninf zero))+(chk-run #f '(> ninf pos))+(chk-run #f '(> ninf pinf))+(chk-run #f '(> neg nan))+(chk-run #t '(> neg ninf))+(chk-run #f '(> neg neg))+(chk-run #f '(> neg zero))+(chk-run #f '(> neg pos))+(chk-run #f '(> neg pinf))+(chk-run #f '(> zero nan))+(chk-run #t '(> zero ninf))+(chk-run #t '(> zero neg))+(chk-run #f '(> zero zero))+(chk-run #f '(> zero pos))+(chk-run #f '(> zero pinf))+(chk-run #f '(> pos nan))+(chk-run #t '(> pos ninf))+(chk-run #t '(> pos neg))+(chk-run #t '(> pos zero))+(chk-run #f '(> pos pos))+(chk-run #f '(> pos pinf))+(chk-run #f '(> pinf nan))+(chk-run #t '(> pinf ninf))+(chk-run #t '(> pinf neg))+(chk-run #t '(> pinf zero))+(chk-run #t '(> pinf pos))+(chk-run #f '(> pinf pinf))++; check comparison operator <=+(chk-run #f '(<= nan nan))+(chk-run #f '(<= nan ninf))+(chk-run #f '(<= nan neg))+(chk-run #f '(<= nan zero))+(chk-run #f '(<= nan pos))+(chk-run #f '(<= nan pinf))+(chk-run #f '(<= ninf nan))+(chk-run #t '(<= ninf ninf))+(chk-run #t '(<= ninf neg))+(chk-run #t '(<= ninf zero))+(chk-run #t '(<= ninf pos))+(chk-run #t '(<= ninf pinf))+(chk-run #f '(<= neg nan))+(chk-run #f '(<= neg ninf))+(chk-run #t '(<= neg neg))+(chk-run #t '(<= neg zero))+(chk-run #t '(<= neg pos))+(chk-run #t '(<= neg pinf))+(chk-run #f '(<= zero nan))+(chk-run #f '(<= zero ninf))+(chk-run #f '(<= zero neg))+(chk-run #t '(<= zero zero))+(chk-run #t '(<= zero pos))+(chk-run #t '(<= zero pinf))+(chk-run #f '(<= pos nan))+(chk-run #f '(<= pos ninf))+(chk-run #f '(<= pos neg))+(chk-run #f '(<= pos zero))+(chk-run #t '(<= pos pos))+(chk-run #t '(<= pos pinf))+(chk-run #f '(<= pinf nan))+(chk-run #f '(<= pinf ninf))+(chk-run #f '(<= pinf neg))+(chk-run #f '(<= pinf zero))+(chk-run #f '(<= pinf pos))+(chk-run #t '(<= pinf pinf))++; check comparison operator >=+(chk-run #f '(>= nan nan))+(chk-run #f '(>= nan ninf))+(chk-run #f '(>= nan neg))+(chk-run #f '(>= nan zero))+(chk-run #f '(>= nan pos))+(chk-run #f '(>= nan pinf))+(chk-run #f '(>= ninf nan))+(chk-run #t '(>= ninf ninf))+(chk-run #f '(>= ninf neg))+(chk-run #f '(>= ninf zero))+(chk-run #f '(>= ninf pos))+(chk-run #f '(>= ninf pinf))+(chk-run #f '(>= neg nan))+(chk-run #t '(>= neg ninf))+(chk-run #t '(>= neg neg))+(chk-run #f '(>= neg zero))+(chk-run #f '(>= neg pos))+(chk-run #f '(>= neg pinf))+(chk-run #f '(>= zero nan))+(chk-run #t '(>= zero ninf))+(chk-run #t '(>= zero neg))+(chk-run #t '(>= zero zero))+(chk-run #f '(>= zero pos))+(chk-run #f '(>= zero pinf))+(chk-run #f '(>= pos nan))+(chk-run #t '(>= pos ninf))+(chk-run #t '(>= pos neg))+(chk-run #t '(>= pos zero))+(chk-run #t '(>= pos pos))+(chk-run #f '(>= pos pinf))+(chk-run #f '(>= pinf nan))+(chk-run #t '(>= pinf ninf))+(chk-run #t '(>= pinf neg))+(chk-run #t '(>= pinf zero))+(chk-run #t '(>= pinf pos))+(chk-run #t '(>= pinf pinf))++; check floating-point comparison operators++(define nan +nan.0)+(define pinf +inf.0)+(define ninf -inf.0)+(define zero 0.0)+(define pos 1.0)+(define neg -1.0)++; check comparison operator =+(chk-run #f '(= nan nan))+(chk-run #f '(= nan ninf))+(chk-run #f '(= nan neg))+(chk-run #f '(= nan zero))+(chk-run #f '(= nan pos))+(chk-run #f '(= nan pinf))+(chk-run #f '(= ninf nan))+(chk-run #t '(= ninf ninf))+(chk-run #f '(= ninf neg))+(chk-run #f '(= ninf zero))+(chk-run #f '(= ninf pos))+(chk-run #f '(= ninf pinf))+(chk-run #f '(= neg nan))+(chk-run #f '(= neg ninf))+(chk-run #t '(= neg neg))+(chk-run #f '(= neg zero))+(chk-run #f '(= neg pos))+(chk-run #f '(= neg pinf))+(chk-run #f '(= zero nan))+(chk-run #f '(= zero ninf))+(chk-run #f '(= zero neg))+(chk-run #t '(= zero zero))+(chk-run #f '(= zero pos))+(chk-run #f '(= zero pinf))+(chk-run #f '(= pos nan))+(chk-run #f '(= pos ninf))+(chk-run #f '(= pos neg))+(chk-run #f '(= pos zero))+(chk-run #t '(= pos pos))+(chk-run #f '(= pos pinf))+(chk-run #f '(= pinf nan))+(chk-run #f '(= pinf ninf))+(chk-run #f '(= pinf neg))+(chk-run #f '(= pinf zero))+(chk-run #f '(= pinf pos))+(chk-run #t '(= pinf pinf))++; check comparison operator /=+(chk-run #t '(/= nan nan))+(chk-run #t '(/= nan ninf))+(chk-run #t '(/= nan neg))+(chk-run #t '(/= nan zero))+(chk-run #t '(/= nan pos))+(chk-run #t '(/= nan pinf))+(chk-run #t '(/= ninf nan))+(chk-run #f '(/= ninf ninf))+(chk-run #t '(/= ninf neg))+(chk-run #t '(/= ninf zero))+(chk-run #t '(/= ninf pos))+(chk-run #t '(/= ninf pinf))+(chk-run #t '(/= neg nan))+(chk-run #t '(/= neg ninf))+(chk-run #f '(/= neg neg))+(chk-run #t '(/= neg zero))+(chk-run #t '(/= neg pos))+(chk-run #t '(/= neg pinf))+(chk-run #t '(/= zero nan))+(chk-run #t '(/= zero ninf))+(chk-run #t '(/= zero neg))+(chk-run #f '(/= zero zero))+(chk-run #t '(/= zero pos))+(chk-run #t '(/= zero pinf))+(chk-run #t '(/= pos nan))+(chk-run #t '(/= pos ninf))+(chk-run #t '(/= pos neg))+(chk-run #t '(/= pos zero))+(chk-run #f '(/= pos pos))+(chk-run #t '(/= pos pinf))+(chk-run #t '(/= pinf nan))+(chk-run #t '(/= pinf ninf))+(chk-run #t '(/= pinf neg))+(chk-run #t '(/= pinf zero))+(chk-run #t '(/= pinf pos))+(chk-run #f '(/= pinf pinf))++; check comparison operator <+(chk-run #f '(< nan nan))+(chk-run #f '(< nan ninf))+(chk-run #f '(< nan neg))+(chk-run #f '(< nan zero))+(chk-run #f '(< nan pos))+(chk-run #f '(< nan pinf))+(chk-run #f '(< ninf nan))+(chk-run #f '(< ninf ninf))+(chk-run #t '(< ninf neg))+(chk-run #t '(< ninf zero))+(chk-run #t '(< ninf pos))+(chk-run #t '(< ninf pinf))+(chk-run #f '(< neg nan))+(chk-run #f '(< neg ninf))+(chk-run #f '(< neg neg))+(chk-run #t '(< neg zero))+(chk-run #t '(< neg pos))+(chk-run #t '(< neg pinf))+(chk-run #f '(< zero nan))+(chk-run #f '(< zero ninf))+(chk-run #f '(< zero neg))+(chk-run #f '(< zero zero))+(chk-run #t '(< zero pos))+(chk-run #t '(< zero pinf))+(chk-run #f '(< pos nan))+(chk-run #f '(< pos ninf))+(chk-run #f '(< pos neg))+(chk-run #f '(< pos zero))+(chk-run #f '(< pos pos))+(chk-run #t '(< pos pinf))+(chk-run #f '(< pinf nan))+(chk-run #f '(< pinf ninf))+(chk-run #f '(< pinf neg))+(chk-run #f '(< pinf zero))+(chk-run #f '(< pinf pos))+(chk-run #f '(< pinf pinf))++; check comparison operator >+(chk-run #f '(> nan nan))+(chk-run #f '(> nan ninf))+(chk-run #f '(> nan neg))+(chk-run #f '(> nan zero))+(chk-run #f '(> nan pos))+(chk-run #f '(> nan pinf))+(chk-run #f '(> ninf nan))+(chk-run #f '(> ninf ninf))+(chk-run #f '(> ninf neg))+(chk-run #f '(> ninf zero))+(chk-run #f '(> ninf pos))+(chk-run #f '(> ninf pinf))+(chk-run #f '(> neg nan))+(chk-run #t '(> neg ninf))+(chk-run #f '(> neg neg))+(chk-run #f '(> neg zero))+(chk-run #f '(> neg pos))+(chk-run #f '(> neg pinf))+(chk-run #f '(> zero nan))+(chk-run #t '(> zero ninf))+(chk-run #t '(> zero neg))+(chk-run #f '(> zero zero))+(chk-run #f '(> zero pos))+(chk-run #f '(> zero pinf))+(chk-run #f '(> pos nan))+(chk-run #t '(> pos ninf))+(chk-run #t '(> pos neg))+(chk-run #t '(> pos zero))+(chk-run #f '(> pos pos))+(chk-run #f '(> pos pinf))+(chk-run #f '(> pinf nan))+(chk-run #t '(> pinf ninf))+(chk-run #t '(> pinf neg))+(chk-run #t '(> pinf zero))+(chk-run #t '(> pinf pos))+(chk-run #f '(> pinf pinf))++; check comparison operator <=+(chk-run #f '(<= nan nan))+(chk-run #f '(<= nan ninf))+(chk-run #f '(<= nan neg))+(chk-run #f '(<= nan zero))+(chk-run #f '(<= nan pos))+(chk-run #f '(<= nan pinf))+(chk-run #f '(<= ninf nan))+(chk-run #t '(<= ninf ninf))+(chk-run #t '(<= ninf neg))+(chk-run #t '(<= ninf zero))+(chk-run #t '(<= ninf pos))+(chk-run #t '(<= ninf pinf))+(chk-run #f '(<= neg nan))+(chk-run #f '(<= neg ninf))+(chk-run #t '(<= neg neg))+(chk-run #t '(<= neg zero))+(chk-run #t '(<= neg pos))+(chk-run #t '(<= neg pinf))+(chk-run #f '(<= zero nan))+(chk-run #f '(<= zero ninf))+(chk-run #f '(<= zero neg))+(chk-run #t '(<= zero zero))+(chk-run #t '(<= zero pos))+(chk-run #t '(<= zero pinf))+(chk-run #f '(<= pos nan))+(chk-run #f '(<= pos ninf))+(chk-run #f '(<= pos neg))+(chk-run #f '(<= pos zero))+(chk-run #t '(<= pos pos))+(chk-run #t '(<= pos pinf))+(chk-run #f '(<= pinf nan))+(chk-run #f '(<= pinf ninf))+(chk-run #f '(<= pinf neg))+(chk-run #f '(<= pinf zero))+(chk-run #f '(<= pinf pos))+(chk-run #t '(<= pinf pinf))++; check comparison operator >=+(chk-run #f '(>= nan nan))+(chk-run #f '(>= nan ninf))+(chk-run #f '(>= nan neg))+(chk-run #f '(>= nan zero))+(chk-run #f '(>= nan pos))+(chk-run #f '(>= nan pinf))+(chk-run #f '(>= ninf nan))+(chk-run #t '(>= ninf ninf))+(chk-run #f '(>= ninf neg))+(chk-run #f '(>= ninf zero))+(chk-run #f '(>= ninf pos))+(chk-run #f '(>= ninf pinf))+(chk-run #f '(>= neg nan))+(chk-run #t '(>= neg ninf))+(chk-run #t '(>= neg neg))+(chk-run #f '(>= neg zero))+(chk-run #f '(>= neg pos))+(chk-run #f '(>= neg pinf))+(chk-run #f '(>= zero nan))+(chk-run #t '(>= zero ninf))+(chk-run #t '(>= zero neg))+(chk-run #t '(>= zero zero))+(chk-run #f '(>= zero pos))+(chk-run #f '(>= zero pinf))+(chk-run #f '(>= pos nan))+(chk-run #t '(>= pos ninf))+(chk-run #t '(>= pos neg))+(chk-run #t '(>= pos zero))+(chk-run #t '(>= pos pos))+(chk-run #f '(>= pos pinf))+(chk-run #f '(>= pinf nan))+(chk-run #t '(>= pinf ninf))+(chk-run #t '(>= pinf neg))+(chk-run #t '(>= pinf zero))+(chk-run #t '(>= pinf pos))+(chk-run #t '(>= pinf pinf))++; check rational arithmetic++(define nan 0/0)+(define pinf 1/0)+(define ninf -1/0)+(define zero 0)+(define pos 1)+(define neg -1)+(define fpnan (sqrt -1.0))++(chk-run nan '(+ nan nan))+(chk-run nan '(+ nan pinf))+(chk-run nan '(+ nan pos))+(chk-run nan '(+ nan zero))+(chk-run nan '(+ nan neg))+(chk-run nan '(+ nan ninf))+(chk-run nan '(+ pinf nan))+(chk-run pinf '(+ pinf pinf))+(chk-run pinf '(+ pinf pos))+(chk-run pinf '(+ pinf zero))+(chk-run pinf '(+ pinf neg))+(chk-run nan '(+ pinf ninf))+(chk-run nan '(+ pos nan))+(chk-run pinf '(+ pos pinf))+(chk-run 2 '(+ pos pos))+(chk-run pos '(+ pos zero))+(chk-run zero '(+ pos neg))+(chk-run ninf '(+ pos ninf))+(chk-run nan '(+ zero nan))+(chk-run pinf '(+ zero pinf))+(chk-run pos '(+ zero pos))+(chk-run zero '(+ zero zero))+(chk-run neg '(+ zero neg))+(chk-run ninf '(+ zero ninf))+(chk-run nan '(+ neg nan))+(chk-run pinf '(+ neg pinf))+(chk-run zero '(+ neg pos))+(chk-run neg '(+ neg zero))+(chk-run -2 '(+ neg neg))+(chk-run ninf '(+ neg ninf))+(chk-run nan '(+ ninf nan))+(chk-run nan '(+ ninf pinf))+(chk-run ninf '(+ ninf pos))+(chk-run ninf '(+ ninf zero))+(chk-run ninf '(+ ninf neg))+(chk-run ninf '(+ ninf ninf))++(chk-run nan '(- nan nan))+(chk-run nan '(- nan pinf))+(chk-run nan '(- nan pos))+(chk-run nan '(- nan zero))+(chk-run nan '(- nan neg))+(chk-run nan '(- nan ninf))+(chk-run nan '(- pinf nan))+(chk-run nan '(- pinf pinf))+(chk-run pinf '(- pinf pos))+(chk-run pinf '(- pinf zero))+(chk-run pinf '(- pinf neg))+(chk-run pinf '(- pinf ninf))+(chk-run nan '(- pos nan))+(chk-run ninf '(- pos pinf))+(chk-run zero '(- pos pos))+(chk-run pos '(- pos zero))+(chk-run 2 '(- pos neg))+(chk-run pinf '(- pos ninf))+(chk-run nan '(- zero nan))+(chk-run ninf '(- zero pinf))+(chk-run neg '(- zero pos))+(chk-run zero '(- zero zero))+(chk-run pos '(- zero neg))+(chk-run pinf '(- zero ninf))+(chk-run nan '(- neg nan))+(chk-run ninf '(- neg pinf))+(chk-run -2 '(- neg pos))+(chk-run neg '(- neg zero))+(chk-run zero '(- neg neg))+(chk-run pinf '(- neg ninf))+(chk-run nan '(- ninf nan))+(chk-run ninf '(- ninf pinf))+(chk-run ninf '(- ninf pos))+(chk-run ninf '(- ninf zero))+(chk-run ninf '(- ninf neg))+(chk-run nan '(- ninf ninf))++(chk-run nan '(* nan nan))+(chk-run nan '(* nan pinf))+(chk-run nan '(* nan pos))+(chk-run nan '(* nan zero))+(chk-run nan '(* nan neg))+(chk-run nan '(* nan ninf))+(chk-run nan '(* pinf nan))+(chk-run pinf '(* pinf pinf))+(chk-run pinf '(* pinf pos))+(chk-run nan '(* pinf zero))+(chk-run ninf '(* pinf neg))+(chk-run ninf '(* pinf ninf))+(chk-run nan '(* pos nan))+(chk-run pinf '(* pos pinf))+(chk-run pos '(* pos pos))+(chk-run zero '(* pos zero))+(chk-run neg '(* pos neg))+(chk-run ninf '(* pos ninf))+(chk-run nan '(* zero nan))+(chk-run nan '(* zero pinf))+(chk-run zero '(* zero pos))+(chk-run zero '(* zero zero))+(chk-run zero '(* zero neg))+(chk-run nan '(* zero ninf))+(chk-run nan '(* neg nan))+(chk-run ninf '(* neg pinf))+(chk-run neg '(* neg pos))+(chk-run zero '(* neg zero))+(chk-run pos '(* neg neg))+(chk-run pinf '(* neg ninf))+(chk-run nan '(* ninf nan))+(chk-run ninf '(* ninf pinf))+(chk-run ninf '(* ninf pos))+(chk-run nan '(* ninf zero))+(chk-run pinf '(* ninf neg))+(chk-run pinf '(* ninf ninf))++(chk-run nan '(/ nan nan))+(chk-run nan '(/ nan pinf))+(chk-run nan '(/ nan pos))+(chk-run nan '(/ nan zero))+(chk-run nan '(/ nan neg))+(chk-run nan '(/ nan ninf))+(chk-run nan '(/ pinf nan))+(chk-run nan '(/ pinf pinf))+(chk-run pinf '(/ pinf pos))+(chk-run pinf '(/ pinf zero))+(chk-run ninf '(/ pinf neg))+(chk-run nan '(/ pinf ninf))+(chk-run nan '(/ pos nan))+(chk-run zero '(/ pos pinf))+(chk-run pos '(/ pos pos))+(chk-run pinf '(/ pos zero))+(chk-run neg '(/ pos neg))+(chk-run zero '(/ pos ninf))+(chk-run nan '(/ zero nan))+(chk-run zero '(/ zero pinf))+(chk-run zero '(/ zero pos))+(chk-run nan '(/ zero zero))+(chk-run zero '(/ zero neg))+(chk-run zero '(/ zero ninf))+(chk-run nan '(/ neg nan))+(chk-run zero '(/ neg pinf))+(chk-run neg '(/ neg pos))+(chk-run ninf '(/ neg zero))+(chk-run pos '(/ neg neg))+(chk-run zero '(/ neg ninf))+(chk-run nan '(/ ninf nan))+(chk-run nan '(/ ninf pinf))+(chk-run ninf '(/ ninf pos))+(chk-run ninf '(/ ninf zero))+(chk-run pinf '(/ ninf neg))+(chk-run nan '(/ ninf ninf))++(chk-run nan '(expt nan nan))+(chk-run nan '(expt nan zero))+(chk-run nan '(expt nan pinf))+(chk-run nan '(expt nan 2))+(chk-run nan '(expt nan pos))+(chk-run nan '(expt nan 1/2))+(chk-run nan '(expt nan ninf))+(chk-run nan '(expt nan -2))+(chk-run nan '(expt nan neg))+(chk-run nan '(expt nan -1/2))+(chk-run nan '(expt zero nan))+(chk-run pos '(expt zero zero))+(chk-run zero '(expt zero pinf))+(chk-run zero '(expt zero 2))+(chk-run zero '(expt zero pos))+(chk-run zero '(expt zero 1/2))+(chk-run pinf '(expt zero ninf))+(chk-run pinf '(expt zero -2))+(chk-run pinf '(expt zero neg))+(chk-run pinf '(expt zero -1/2))+(chk-run nan '(expt pinf nan))+(chk-run nan '(expt pinf zero))+(chk-run pinf '(expt pinf pinf))+(chk-run pinf '(expt pinf 2))+(chk-run pinf '(expt pinf pos))+(chk-run pinf '(expt pinf 1/2))+(chk-run zero '(expt pinf ninf))+(chk-run zero '(expt pinf -2))+(chk-run zero '(expt pinf neg))+(chk-run zero '(expt pinf -1/2))+(chk-run nan '(expt 2 nan))+(chk-run pos '(expt 2 zero))+(chk-run pinf '(expt 2 pinf))+(chk-run 4 '(expt 2 2))+(chk-run 2 '(expt 2 pos))+(chk-run (sqrt 2) '(expt 2 1/2))+(chk-run zero '(expt 2 ninf))+(chk-run 1/4 '(expt 2 -2))+(chk-run 1/2 '(expt 2 neg))+(chk-run (sqrt 0.5) '(expt 2 -1/2))+(chk-run nan '(expt pos nan))+(chk-run pos '(expt pos zero))+(chk-run pos '(expt pos pinf))+(chk-run pos '(expt pos 2))+(chk-run pos '(expt pos pos))+(chk-run pos '(expt pos 1/2))+(chk-run pos '(expt pos ninf))+(chk-run pos '(expt pos -2))+(chk-run pos '(expt pos neg))+(chk-run pos '(expt pos -1/2))+(chk-run nan '(expt 1/2 nan))+(chk-run pos '(expt 1/2 zero))+(chk-run zero '(expt 1/2 pinf))+(chk-run 1/4 '(expt 1/2 2))+(chk-run 1/2 '(expt 1/2 pos))+(chk-run (sqrt 0.5) '(expt 1/2 1/2))+(chk-run pinf '(expt 1/2 ninf))+(chk-run 4 '(expt 1/2 -2))+(chk-run 2 '(expt 1/2 neg))+(chk-run (sqrt 2) '(expt 1/2 -1/2))+(chk-run nan '(expt ninf nan))+(chk-run nan '(expt ninf zero))+(chk-run nan '(expt ninf pinf))+(chk-run pinf '(expt ninf 2))+(chk-run ninf '(expt ninf pos))+(chk-run nan '(expt ninf 1/2))+(chk-run zero '(expt ninf ninf))+(chk-run zero '(expt ninf -2))+(chk-run zero '(expt ninf neg))+(chk-run zero '(expt ninf -1/2))+(chk-run nan '(expt -2 nan))+(chk-run pos '(expt -2 zero))+(chk-run nan '(expt -2 pinf))+(chk-run 4 '(expt -2 2))+(chk-run -2 '(expt -2 pos))+(chk-run fpnan '(expt -2 1/2)) ; should be complex+(chk-run zero '(expt -2 ninf))+(chk-run 1/4 '(expt -2 -2))+(chk-run -1/2 '(expt -2 neg))+(chk-run fpnan '(expt -2 -1/2)) ; should be complex+(chk-run nan '(expt neg nan))+(chk-run pos '(expt neg zero))+(chk-run nan '(expt neg pinf))+(chk-run pos '(expt neg 2))+(chk-run neg '(expt neg pos))+(chk-run fpnan '(expt neg 1/2)) ; should be complex+(chk-run nan '(expt neg ninf))+(chk-run pos '(expt neg -2))+(chk-run neg '(expt neg neg))+(chk-run fpnan '(expt neg -1/2)) ; should be complex+(chk-run nan '(expt -1/2 nan))+(chk-run pos '(expt -1/2 zero))+(chk-run zero '(expt -1/2 pinf))+(chk-run 1/4 '(expt -1/2 2))+(chk-run -1/2 '(expt -1/2 pos))+(chk-run fpnan '(expt -1/2 1/2)) ; should be complex+(chk-run nan '(expt -1/2 ninf))+(chk-run 4 '(expt -1/2 -2))+(chk-run -2 '(expt -1/2 neg))+(chk-run fpnan '(expt -1/2 -1/2)) ; should be complex++(chk-run nan '(max nan nan))+(chk-run nan '(max nan pinf))+(chk-run nan '(max nan pos))+(chk-run nan '(max nan zero))+(chk-run nan '(max nan neg))+(chk-run nan '(max nan ninf))+(chk-run nan '(max pinf nan))+(chk-run pinf '(max pinf pinf))+(chk-run pinf '(max pinf pos))+(chk-run pinf '(max pinf zero))+(chk-run pinf '(max pinf neg))+(chk-run pinf '(max pinf ninf))+(chk-run nan '(max pos nan))+(chk-run pinf '(max pos pinf))+(chk-run pos '(max pos pos))+(chk-run pos '(max pos zero))+(chk-run pos '(max pos neg))+(chk-run pos '(max pos ninf))+(chk-run nan '(max zero nan))+(chk-run pinf '(max zero pinf))+(chk-run pos '(max zero pos))+(chk-run zero '(max zero zero))+(chk-run zero '(max zero neg))+(chk-run zero '(max zero ninf))+(chk-run nan '(max neg nan))+(chk-run pinf '(max neg pinf))+(chk-run pos '(max neg pos))+(chk-run zero '(max neg zero))+(chk-run neg '(max neg neg))+(chk-run neg '(max neg ninf))+(chk-run nan '(max ninf nan))+(chk-run pinf '(max ninf pinf))+(chk-run pos '(max ninf pos))+(chk-run zero '(max ninf zero))+(chk-run neg '(max ninf neg))+(chk-run ninf '(max ninf ninf))++(chk-run nan '(min nan nan))+(chk-run nan '(min nan pinf))+(chk-run nan '(min nan pos))+(chk-run nan '(min nan zero))+(chk-run nan '(min nan neg))+(chk-run nan '(min nan ninf))+(chk-run nan '(min pinf nan))+(chk-run pinf '(min pinf pinf))+(chk-run pos '(min pinf pos))+(chk-run zero '(min pinf zero))+(chk-run neg '(min pinf neg))+(chk-run ninf '(min pinf ninf))+(chk-run nan '(min pos nan))+(chk-run pos '(min pos pinf))+(chk-run pos '(min pos pos))+(chk-run zero '(min pos zero))+(chk-run neg '(min pos neg))+(chk-run ninf '(min pos ninf))+(chk-run nan '(min zero nan))+(chk-run zero '(min zero pinf))+(chk-run zero '(min zero pos))+(chk-run zero '(min zero zero))+(chk-run neg '(min zero neg))+(chk-run ninf '(min zero ninf))+(chk-run nan '(min neg nan))+(chk-run neg '(min neg pinf))+(chk-run neg '(min neg pos))+(chk-run neg '(min neg zero))+(chk-run neg '(min neg neg))+(chk-run ninf '(min neg ninf))+(chk-run nan '(min ninf nan))+(chk-run ninf '(min ninf pinf))+(chk-run ninf '(min ninf pos))+(chk-run ninf '(min ninf zero))+(chk-run ninf '(min ninf neg))+(chk-run ninf '(min ninf ninf))++; check floating-point arithmetic++(define nan +nan.0)+(define pinf +inf.0)+(define ninf -inf.0)+(define zero 0.0)+(define pos 1.0)+(define neg -1.0)+(define fpnan (sqrt -1.0))+(define ptwo 2.0)+(define ntwo -2.0)+(define phalf 0.5)+(define nhalf -0.5)+(define pfour 4.0)+(define nfour -4.0)+(define pqtr 0.25)+(define nqtr -0.25)++(chk-run nan '(+ nan nan))+(chk-run nan '(+ nan pinf))+(chk-run nan '(+ nan pos))+(chk-run nan '(+ nan zero))+(chk-run nan '(+ nan neg))+(chk-run nan '(+ nan ninf))+(chk-run nan '(+ pinf nan))+(chk-run pinf '(+ pinf pinf))+(chk-run pinf '(+ pinf pos))+(chk-run pinf '(+ pinf zero))+(chk-run pinf '(+ pinf neg))+(chk-run nan '(+ pinf ninf))+(chk-run nan '(+ pos nan))+(chk-run pinf '(+ pos pinf))+(chk-run ptwo '(+ pos pos))+(chk-run pos '(+ pos zero))+(chk-run zero '(+ pos neg))+(chk-run ninf '(+ pos ninf))+(chk-run nan '(+ zero nan))+(chk-run pinf '(+ zero pinf))+(chk-run pos '(+ zero pos))+(chk-run zero '(+ zero zero))+(chk-run neg '(+ zero neg))+(chk-run ninf '(+ zero ninf))+(chk-run nan '(+ neg nan))+(chk-run pinf '(+ neg pinf))+(chk-run zero '(+ neg pos))+(chk-run neg '(+ neg zero))+(chk-run ntwo '(+ neg neg))+(chk-run ninf '(+ neg ninf))+(chk-run nan '(+ ninf nan))+(chk-run nan '(+ ninf pinf))+(chk-run ninf '(+ ninf pos))+(chk-run ninf '(+ ninf zero))+(chk-run ninf '(+ ninf neg))+(chk-run ninf '(+ ninf ninf))++(chk-run nan '(- nan nan))+(chk-run nan '(- nan pinf))+(chk-run nan '(- nan pos))+(chk-run nan '(- nan zero))+(chk-run nan '(- nan neg))+(chk-run nan '(- nan ninf))+(chk-run nan '(- pinf nan))+(chk-run nan '(- pinf pinf))+(chk-run pinf '(- pinf pos))+(chk-run pinf '(- pinf zero))+(chk-run pinf '(- pinf neg))+(chk-run pinf '(- pinf ninf))+(chk-run nan '(- pos nan))+(chk-run ninf '(- pos pinf))+(chk-run zero '(- pos pos))+(chk-run pos '(- pos zero))+(chk-run ptwo '(- pos neg))+(chk-run pinf '(- pos ninf))+(chk-run nan '(- zero nan))+(chk-run ninf '(- zero pinf))+(chk-run neg '(- zero pos))+(chk-run zero '(- zero zero))+(chk-run pos '(- zero neg))+(chk-run pinf '(- zero ninf))+(chk-run nan '(- neg nan))+(chk-run ninf '(- neg pinf))+(chk-run ntwo '(- neg pos))+(chk-run neg '(- neg zero))+(chk-run zero '(- neg neg))+(chk-run pinf '(- neg ninf))+(chk-run nan '(- ninf nan))+(chk-run ninf '(- ninf pinf))+(chk-run ninf '(- ninf pos))+(chk-run ninf '(- ninf zero))+(chk-run ninf '(- ninf neg))+(chk-run nan '(- ninf ninf))++(chk-run nan '(* nan nan))+(chk-run nan '(* nan pinf))+(chk-run nan '(* nan pos))+(chk-run nan '(* nan zero))+(chk-run nan '(* nan neg))+(chk-run nan '(* nan ninf))+(chk-run nan '(* pinf nan))+(chk-run pinf '(* pinf pinf))+(chk-run pinf '(* pinf pos))+(chk-run nan '(* pinf zero))+(chk-run ninf '(* pinf neg))+(chk-run ninf '(* pinf ninf))+(chk-run nan '(* pos nan))+(chk-run pinf '(* pos pinf))+(chk-run pos '(* pos pos))+(chk-run zero '(* pos zero))+(chk-run neg '(* pos neg))+(chk-run ninf '(* pos ninf))+(chk-run nan '(* zero nan))+(chk-run nan '(* zero pinf))+(chk-run zero '(* zero pos))+(chk-run zero '(* zero zero))+(chk-run zero '(* zero neg))+(chk-run nan '(* zero ninf))+(chk-run nan '(* neg nan))+(chk-run ninf '(* neg pinf))+(chk-run neg '(* neg pos))+(chk-run zero '(* neg zero))+(chk-run pos '(* neg neg))+(chk-run pinf '(* neg ninf))+(chk-run nan '(* ninf nan))+(chk-run ninf '(* ninf pinf))+(chk-run ninf '(* ninf pos))+(chk-run nan '(* ninf zero))+(chk-run pinf '(* ninf neg))+(chk-run pinf '(* ninf ninf))++(chk-run nan '(/ nan nan))+(chk-run nan '(/ nan pinf))+(chk-run nan '(/ nan pos))+(chk-run nan '(/ nan zero))+(chk-run nan '(/ nan neg))+(chk-run nan '(/ nan ninf))+(chk-run nan '(/ pinf nan))+(chk-run nan '(/ pinf pinf))+(chk-run pinf '(/ pinf pos))+(chk-run pinf '(/ pinf zero))+(chk-run ninf '(/ pinf neg))+(chk-run nan '(/ pinf ninf))+(chk-run nan '(/ pos nan))+(chk-run zero '(/ pos pinf))+(chk-run pos '(/ pos pos))+(chk-run pinf '(/ pos zero))+(chk-run neg '(/ pos neg))+(chk-run zero '(/ pos ninf))+(chk-run nan '(/ zero nan))+(chk-run zero '(/ zero pinf))+(chk-run zero '(/ zero pos))+(chk-run nan '(/ zero zero))+(chk-run zero '(/ zero neg))+(chk-run zero '(/ zero ninf))+(chk-run nan '(/ neg nan))+(chk-run zero '(/ neg pinf))+(chk-run neg '(/ neg pos))+(chk-run ninf '(/ neg zero))+(chk-run pos '(/ neg neg))+(chk-run zero '(/ neg ninf))+(chk-run nan '(/ ninf nan))+(chk-run nan '(/ ninf pinf))+(chk-run ninf '(/ ninf pos))+(chk-run ninf '(/ ninf zero))+(chk-run pinf '(/ ninf neg))+(chk-run nan '(/ ninf ninf))++(chk-run nan '(expt nan nan))+(chk-run nan '(expt nan zero))+(chk-run nan '(expt nan pinf))+(chk-run nan '(expt nan ptwo))+(chk-run nan '(expt nan pos))+(chk-run nan '(expt nan phalf))+(chk-run nan '(expt nan ninf))+(chk-run nan '(expt nan ntwo))+(chk-run nan '(expt nan neg))+(chk-run nan '(expt nan nhalf))+(chk-run nan '(expt zero nan))+(chk-run 1 '(expt zero zero))+(chk-run 0 '(expt zero pinf))+(chk-run 0 '(expt zero ptwo))+(chk-run 0 '(expt zero pos))+(chk-run 0 '(expt zero phalf))+(chk-run 1/0 '(expt zero ninf))+(chk-run 1/0 '(expt zero ntwo))+(chk-run 1/0 '(expt zero neg))+(chk-run 1/0 '(expt zero nhalf))+(chk-run nan '(expt pinf nan))+(chk-run nan '(expt pinf zero))+(chk-run pinf '(expt pinf pinf))+(chk-run pinf '(expt pinf ptwo))+(chk-run pinf '(expt pinf pos))+(chk-run pinf '(expt pinf phalf))+(chk-run 0 '(expt pinf ninf))+(chk-run zero '(expt pinf ntwo))+(chk-run zero '(expt pinf neg))+(chk-run zero '(expt pinf nhalf))+(chk-run nan '(expt ptwo nan))+(chk-run 1 '(expt ptwo zero))+(chk-run pinf '(expt ptwo pinf))+(chk-run pfour '(expt ptwo ptwo))+(chk-run ptwo '(expt ptwo pos))+(chk-run (sqrt ptwo) '(expt ptwo phalf))+(chk-run 0 '(expt ptwo ninf))+(chk-run pqtr '(expt ptwo ntwo))+(chk-run phalf '(expt ptwo neg))+(chk-run (sqrt 0.5) '(expt ptwo nhalf))+(chk-run nan '(expt pos nan))+(chk-run 1 '(expt pos zero))+(chk-run pos '(expt pos pinf))+(chk-run pos '(expt pos ptwo))+(chk-run pos '(expt pos pos))+(chk-run pos '(expt pos phalf))+(chk-run pos '(expt pos ninf))+(chk-run pos '(expt pos ntwo))+(chk-run pos '(expt pos neg))+(chk-run pos '(expt pos nhalf))+(chk-run nan '(expt phalf nan))+(chk-run 1 '(expt phalf zero))+(chk-run 0 '(expt phalf pinf))+(chk-run pqtr '(expt phalf ptwo))+(chk-run phalf '(expt phalf pos))+(chk-run (sqrt 0.5) '(expt phalf phalf))+(chk-run pinf '(expt phalf ninf))+(chk-run pfour '(expt phalf ntwo))+(chk-run ptwo '(expt phalf neg))+(chk-run (sqrt ptwo) '(expt phalf nhalf))+(chk-run nan '(expt ninf nan))+(chk-run nan '(expt ninf zero))+(chk-run nan '(expt ninf pinf))+(chk-run pinf '(expt ninf ptwo))+(chk-run ninf '(expt ninf pos))+(chk-run nan '(expt ninf phalf))+(chk-run 0 '(expt ninf ninf))+(chk-run zero '(expt ninf ntwo))+(chk-run zero '(expt ninf neg))+(chk-run zero '(expt ninf nhalf))+(chk-run nan '(expt ntwo nan))+(chk-run 1 '(expt ntwo zero))+(chk-run nan '(expt ntwo pinf))+(chk-run pfour '(expt ntwo ptwo))+(chk-run ntwo '(expt ntwo pos))+(chk-run fpnan '(expt ntwo phalf)) ; should be complex+(chk-run 0 '(expt ntwo ninf))+(chk-run pqtr '(expt ntwo ntwo))+(chk-run nhalf '(expt ntwo neg))+(chk-run fpnan '(expt ntwo nhalf)) ; should be complex+(chk-run nan '(expt neg nan))+(chk-run 1 '(expt neg zero))+(chk-run nan '(expt neg pinf))+(chk-run pos '(expt neg ptwo))+(chk-run neg '(expt neg pos))+(chk-run fpnan '(expt neg phalf)) ; should be complex+(chk-run nan '(expt neg ninf))+(chk-run pos '(expt neg ntwo))+(chk-run neg '(expt neg neg))+(chk-run fpnan '(expt neg nhalf)) ; should be complex+(chk-run nan '(expt nhalf nan))+(chk-run 1 '(expt nhalf zero))+(chk-run 0 '(expt nhalf pinf))+(chk-run pqtr '(expt nhalf ptwo))+(chk-run nhalf '(expt nhalf pos))+(chk-run fpnan '(expt nhalf phalf)) ; should be complex+(chk-run nan '(expt nhalf ninf))+(chk-run pfour '(expt nhalf ntwo))+(chk-run ntwo '(expt nhalf neg))+(chk-run fpnan '(expt nhalf nhalf)) ; should be complex++(chk-run nan '(max nan nan))+(chk-run nan '(max nan pinf))+(chk-run nan '(max nan pos))+(chk-run nan '(max nan zero))+(chk-run nan '(max nan neg))+(chk-run nan '(max nan ninf))+(chk-run nan '(max pinf nan))+(chk-run pinf '(max pinf pinf))+(chk-run pinf '(max pinf pos))+(chk-run pinf '(max pinf zero))+(chk-run pinf '(max pinf neg))+(chk-run pinf '(max pinf ninf))+(chk-run nan '(max pos nan))+(chk-run pinf '(max pos pinf))+(chk-run pos '(max pos pos))+(chk-run pos '(max pos zero))+(chk-run pos '(max pos neg))+(chk-run pos '(max pos ninf))+(chk-run nan '(max zero nan))+(chk-run pinf '(max zero pinf))+(chk-run pos '(max zero pos))+(chk-run zero '(max zero zero))+(chk-run zero '(max zero neg))+(chk-run zero '(max zero ninf))+(chk-run nan '(max neg nan))+(chk-run pinf '(max neg pinf))+(chk-run pos '(max neg pos))+(chk-run zero '(max neg zero))+(chk-run neg '(max neg neg))+(chk-run neg '(max neg ninf))+(chk-run nan '(max ninf nan))+(chk-run pinf '(max ninf pinf))+(chk-run pos '(max ninf pos))+(chk-run zero '(max ninf zero))+(chk-run neg '(max ninf neg))+(chk-run ninf '(max ninf ninf))++(chk-run nan '(min nan nan))+(chk-run nan '(min nan pinf))+(chk-run nan '(min nan pos))+(chk-run nan '(min nan zero))+(chk-run nan '(min nan neg))+(chk-run nan '(min nan ninf))+(chk-run nan '(min pinf nan))+(chk-run pinf '(min pinf pinf))+(chk-run pos '(min pinf pos))+(chk-run zero '(min pinf zero))+(chk-run neg '(min pinf neg))+(chk-run ninf '(min pinf ninf))+(chk-run nan '(min pos nan))+(chk-run pos '(min pos pinf))+(chk-run pos '(min pos pos))+(chk-run zero '(min pos zero))+(chk-run neg '(min pos neg))+(chk-run ninf '(min pos ninf))+(chk-run nan '(min zero nan))+(chk-run zero '(min zero pinf))+(chk-run zero '(min zero pos))+(chk-run zero '(min zero zero))+(chk-run neg '(min zero neg))+(chk-run ninf '(min zero ninf))+(chk-run nan '(min neg nan))+(chk-run neg '(min neg pinf))+(chk-run neg '(min neg pos))+(chk-run neg '(min neg zero))+(chk-run neg '(min neg neg))+(chk-run ninf '(min neg ninf))+(chk-run nan '(min ninf nan))+(chk-run ninf '(min ninf pinf))+(chk-run ninf '(min ninf pos))+(chk-run ninf '(min ninf zero))+(chk-run ninf '(min ninf neg))+(chk-run ninf '(min ninf ninf))++(chk-run #t '(= (atan 1.0 2.0) (atan 1/2)))+(chk-run #t '(/= (atan -1.0 -2.0) (atan 1/2)))++(chk-run '(0 0) '(exact-integer-sqrt 0))+(chk-run '(1 0) '(exact-integer-sqrt 1))+(chk-run '(3 1) '(exact-integer-sqrt 10))+(chk-run '(10 0) '(exact-integer-sqrt 100))+(chk-run '(111111110611 24691096802)+ '(exact-integer-sqrt 12345678901234567890123))+(chk-run (list (expt 101 51) 101)+ '(exact-integer-sqrt (+ (expt 101 102) 101)))++(chk-run '(0 0) '(exact-integer-cbrt 0))+(chk-run '(1 0) '(exact-integer-cbrt 1))+(chk-run '(2 2) '(exact-integer-cbrt 10))+(chk-run '(10 0) '(exact-integer-cbrt 1000))+(chk-run '(23112042 655451715112035)+ '(exact-integer-cbrt 12345678901234567890123))+(chk-run '(-23112042 -655451715112035)+ '(exact-integer-cbrt -12345678901234567890123))+(chk-run (list (expt 101 51) 101)+ '(exact-integer-cbrt (+ (expt 101 153) 101)))++(define natural-numbers+ (letrec ((next+ (lambda (n)+ (cons n (delay (next (+ n 1)))))))+ (next 1)))++(chk-run '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20)+ '(stream-head natural-numbers 20))++(chk-run '(2 4 6 8 10 12 14 16 18 20 22 24 26 28 30 32 34 36 38 40)+ '(stream-head (stream-map (lambda (n) (* 2 n)) natural-numbers) 20))++; check that a promise is not redeemed more than once+; this is taken pretty directly from R6RS++(define promise-count 0)+(define promise+ (delay (begin (set! promise-count (+ promise-count 1))+ (if (>= promise-count promise-target)+ promise-count+ (force promise)))))+(define promise-target 5)+(chk-run 5 '(force promise))+(set! promise-target 10)+(chk-run 5 '(force promise))++; summarize these results++(write-string "\ntotal tests run: "+ (number->string n-tests)+ "\ntests failed: "+ (number->string n-fails)+ #\linefeed)++(write-string+ "\nThe next series of tests are going to check interactions with\n"+ "the outside world. Some of these are not so easy to check, so haskeem\n"+ "will just print the results and assume that they are good. If you\n"+ "re-run the test in verbose mode by adding '-v' to the command line,\n"+ "you will have a chance to verify whether they are reasonable.\n\n")++(chk-query "your home directory" '(get-environment "HOME"))+(chk-query "the current local time" '(localtime))+(chk-query "the current local time" '(localtime (epochtime)))+(chk-query "the current UTC time" '(UTCtime))+(chk-query "the current UTC time" '(UTCtime (epochtime)))+(chk-query "current directory" '(get-current-directory))++; these need to be global because apparently eval isn't picking them+; up if I define them via let inside do-dir-tests... which is right+; according to the R6RS, but ought not be the case in my version,+; due to eval being a special form: it should have access to the+; current environment, in which these should be bound. TODO: check that!++(define test-dir1 "scratch-dir")+(define test-file1 (string-join-by "/" (list test-dir1 "testfile1")))+(define test-file2 (string-join-by "/" (list test-dir1 "testfile2")))+(define test-dir2 (string-join-by "/" (list test-dir1 "subdir")))+(define line1 "This is a test")+(define line2 "no")+(define port 0)++(define (ssort lst) (list-sort string<? lst))++(define (do-dir-tests)+ (chk-run #f '(directory-exists? test-dir1))+ (chk-run #t '(create-directory test-dir1))+ (chk-run #t '(create-directory test-dir2))+ (chk-run (ssort '("." ".." "subdir")) '(ssort (read-directory test-dir1)))+ (chk-run #t '(remove-directory test-dir2))+ (chk-run #f '(file-exists? test-file1))+ (set! port (open-output-file test-file1))+ (chk-run #t '(file-exists? test-file1))+ (write-string port line1 #\linefeed)+ (close-port port)+ (chk-run #t '(rename-file test-file1 test-file2))+ (chk-run (ssort '("." ".." "testfile2")) '(ssort (read-directory test-dir1)))+ (chk-run #f '(file-exists? test-file1))+ (chk-run #t '(file-exists? test-file2))+ (set! port (open-input-file test-file2))+ (set! line2 (read-line port))+ (chk-run #t '(string=? line1 line2))+ (chk-run #t '(remove-file test-file2))+ (chk-run #f '(file-exists? test-file2))+ (chk-run (ssort '("." "..")) '(ssort (read-directory test-dir1)))+ (chk-run #t '(set-current-directory test-dir1))+ (chk-query "test directory" '(get-current-directory))+ (chk-run #t '(set-current-directory ".."))+ (chk-run #t '(remove-directory test-dir1)))++(if (directory-exists? test-dir1)+ (write-string "\nSkipping file and directory I/O tests,\n"+ "test directory \""+ test-dir1+ "\" seems to already exist...\n")+ (do-dir-tests))++(chk-run '((1 4 a d) (2 5 b e) (3 6 c f))+ '(begin (define acc '())+ (for-each (lambda v (set! acc (cons v acc)))+ '(1 2 3)+ '(4 5 6)+ '(a b c)+ '(d e f))+ (reverse acc)))++(chk-run '((1) (2)) '(begin (define acc '())+ (for-all-combinations+ (lambda v (set! acc (cons v acc)))+ '((1 2)))+ (reverse acc)))++(chk-run '((1) (2)) '(begin (define acc '())+ (for-all-combinations+ (lambda v (set! acc (cons v acc)))+ '() '(1 2))+ (reverse acc)))++(chk-run '(((1 2))) '(begin (define acc '())+ (for-all-combinations+ (lambda v (set! acc (cons v acc)))+ '(((1 2))))+ (reverse acc)))++(chk-run '(((1 2))) '(begin (define acc '())+ (for-all-combinations+ (lambda v (set! acc (cons v acc)))+ '() '((1 2)))+ (reverse acc)))++(chk-run '((1 a) (1 b) (2 a) (2 b)) '(begin (define acc '())+ (for-all-combinations+ (lambda v (set! acc (cons v acc)))+ '((1 2) (a b)))+ (reverse acc)))++(chk-run '((1 a) (1 b) (2 a) (2 b)) '(begin (define acc '())+ (for-all-combinations+ (lambda v (set! acc (cons v acc)))+ '() '(1 2) '(a b))+ (reverse acc)))++(chk-run '(((1 2)) ((a b))) '(begin (define acc '())+ (for-all-combinations+ (lambda v (set! acc (cons v acc)))+ '(((1 2) (a b))))+ (reverse acc)))++(chk-run '(((1 2)) ((a b))) '(begin (define acc '())+ (for-all-combinations+ (lambda v (set! acc (cons v acc)))+ '() '((1 2) (a b)))+ (reverse acc)))++(chk-run '((1 a 4) (1 a 5) (1 b 4) (1 b 5) (2 a 4) (2 a 5) (2 b 4) (2 b 5))+ '(begin (define acc '())+ (for-all-combinations (lambda v (set! acc (cons v acc)))+ '((1 2) (a b) (4 5)))+ (reverse acc)))++(chk-run '((1 a 4) (1 a 5) (1 b 4) (1 b 5) (2 a 4) (2 a 5) (2 b 4) (2 b 5))+ '(begin (define acc '())+ (for-all-combinations (lambda v (set! acc (cons v acc)))+ '() '(1 2) '(a b) '(4 5))+ (reverse acc)))++(chk-run "#b0.0" '(number->string 1/4 2 1))+(chk-run "#b0.01" '(number->string 1/4 2 2))+(chk-run "#b0.010" '(number->string 1/4 2 3))+(chk-run "#b0.0100" '(number->string 1/4 2 4))+(chk-run "#o0.2" '(number->string 1/4 8 1))+(chk-run "#o0.20" '(number->string 1/4 8 2))+(chk-run "#o0.200" '(number->string 1/4 8 3))+(chk-run "#o0.2000" '(number->string 1/4 8 4))+(chk-run "0.2" '(number->string 1/4 10 1))+(chk-run "0.25" '(number->string 1/4 10 2))+(chk-run "0.250" '(number->string 1/4 10 3))+(chk-run "0.2500" '(number->string 1/4 10 4))+(chk-run "#x0.4" '(number->string 1/4 16 1))+(chk-run "#x0.40" '(number->string 1/4 16 2))+(chk-run "#x0.400" '(number->string 1/4 16 3))+(chk-run "#x0.4000" '(number->string 1/4 16 4))++(chk-run "0.3" '(number->string 1/3 10 1))+(chk-run "0.33" '(number->string 1/3 10 2))+(chk-run "0.333" '(number->string 1/3 10 3))+(chk-run "0.3333" '(number->string 1/3 10 4))+(chk-run "0.7" '(number->string 2/3 10 1))+(chk-run "0.67" '(number->string 2/3 10 2))+(chk-run "0.667" '(number->string 2/3 10 3))+(chk-run "0.6667" '(number->string 2/3 10 4))++(chk-run "1.0" '(number->string 999/1000 10 1))+(chk-run "1.00" '(number->string 999/1000 10 2))+(chk-run "0.999" '(number->string 999/1000 10 3))+(chk-run "0.9990" '(number->string 999/1000 10 4))+(chk-run "0.99900" '(number->string 999/1000 10 5))++(chk-run "#b-0.0" '(number->string -1/4 2 1))+(chk-run "#b-0.01" '(number->string -1/4 2 2))+(chk-run "#b-0.010" '(number->string -1/4 2 3))+(chk-run "#b-0.0100" '(number->string -1/4 2 4))+(chk-run "#o-0.2" '(number->string -1/4 8 1))+(chk-run "#o-0.20" '(number->string -1/4 8 2))+(chk-run "#o-0.200" '(number->string -1/4 8 3))+(chk-run "#o-0.2000" '(number->string -1/4 8 4))+(chk-run "-0.2" '(number->string -1/4 10 1))+(chk-run "-0.25" '(number->string -1/4 10 2))+(chk-run "-0.250" '(number->string -1/4 10 3))+(chk-run "-0.2500" '(number->string -1/4 10 4))+(chk-run "#x-0.4" '(number->string -1/4 16 1))+(chk-run "#x-0.40" '(number->string -1/4 16 2))+(chk-run "#x-0.400" '(number->string -1/4 16 3))+(chk-run "#x-0.4000" '(number->string -1/4 16 4))++(chk-run "-0.3" '(number->string -1/3 10 1))+(chk-run "-0.33" '(number->string -1/3 10 2))+(chk-run "-0.333" '(number->string -1/3 10 3))+(chk-run "-0.3333" '(number->string -1/3 10 4))+(chk-run "-0.7" '(number->string -2/3 10 1))+(chk-run "-0.67" '(number->string -2/3 10 2))+(chk-run "-0.667" '(number->string -2/3 10 3))+(chk-run "-0.6667" '(number->string -2/3 10 4))++(chk-run "-1.0" '(number->string -999/1000 10 1))+(chk-run "-1.00" '(number->string -999/1000 10 2))+(chk-run "-0.999" '(number->string -999/1000 10 3))+(chk-run "-0.9990" '(number->string -999/1000 10 4))+(chk-run "-0.99900" '(number->string -999/1000 10 5))++; convert the number to a string with the inner (number->string);+; convert that back to a number with (string->number) and find the+; difference between that and the original number: it should be+; no more than 0.5 unit in the last digit -- actually, it seems that+; due to finiteness of FP arithmetic it can be just a smidgen larger+; than 0.5 ULP++(define (chk-reversible val base prec)+ (set! n-tests (+ n-tests 1))+ (let* ((vs (number->string val base prec))+ (diff (abs (- val (string->number vs))))+ (ddif (* (expt base prec) diff)))+ (if (> ddif 0.5000000001)+ (begin (set! n-fails (+ n-fails 1))+ (write-string "reversible failed! "+ (number->string val)+ " -> " vs+ " ULPdiff = "+ (number->string ddif)+ #\linefeed)))))++(write-string "\nNow test number/string conversions... "+ "this'll take a bit longer\n\n")++(do ((j 1 (+ j 13)))+ ((> j 2000) #t)+ (do ((i 1 (+ i 21)))+ ((> i 5000) #t)+ (chk-reversible (/ i j) 10 2)))++(write-string "Again, this time with floating-point numbers\n\n")++(do ((j 1 (+ j 17)))+ ((> j 2000) #t)+ (do ((i 1 (+ i 19)))+ ((> i 5000) #t)+ (chk-reversible (/ (+ i 0.0) (+ j 0.0)) 10 2)))++(chk-run 3 '(ilog (- (expt 2 4) 1)))+(chk-run 4 '(ilog (expt 2 4)))+(chk-run 11 '(ilog (- (expt 2 12) 1)))+(chk-run 12 '(ilog (expt 2 12)))+(chk-run 26 '(ilog (- (expt 2 27) 1)))+(chk-run 27 '(ilog (expt 2 27)))+(chk-run 1242 '(ilog (- (expt 2 1243) 1)))+(chk-run 1243 '(ilog (expt 2 1243)))++(chk-run "1.2345e0" '(number->string 1.2345))+(chk-run "1.2345e0" '(number->string 1.2345 10))+(chk-run "1.2345" '(number->string 1.2345 10 4))+(chk-run "1.23450" '(number->string 1.2345 10 5))+(chk-run "1.234500" '(number->string 1.2345 10 6))++(chk-run "1.234" '(number->string 1.2345 10 3))+(chk-run "1.23" '(number->string 1.2345 10 2))+(chk-run "1.2" '(number->string 1.2345 10 1))+(chk-run "1." '(number->string 1.2345 10 0))+(chk-run "1.2e0" '(number->string 1.2345 10 -1))+(chk-run "1.23e0" '(number->string 1.2345 10 -2))++(chk-run "1.234e0" '(number->string 1.2345 10 -3))+(chk-run "1.2345e0" '(number->string 1.2345 10 -4))+(chk-run "1.2345e0" '(number->string 12345e-4 10 -4))+(chk-run "1.2345" '(number->string 12345/10000 10 4))+(chk-run "1.2345e0" '(number->string 12345/10000 10 -4))++(chk-run "1.0" '(number->string 0.99999 10 1))+(chk-run "1.00" '(number->string 0.99999 10 2))+(chk-run "1.000" '(number->string 0.99999 10 3))+(chk-run "1.0000" '(number->string 0.99999 10 4))+(chk-run "0.99999" '(number->string 0.99999 10 5))+(chk-run "0.999990" '(number->string 0.99999 10 6))++(chk-run "1.0e0" '(number->string 0.99999 10 -1))+(chk-run "1.00e0" '(number->string 0.99999 10 -2))+(chk-run "1.000e0" '(number->string 0.99999 10 -3))+(chk-run "9.9999e-1" '(number->string 0.99999 10 -4))+(chk-run "9.99990e-1" '(number->string 0.99999 10 -5))+(chk-run "9.999900e-1" '(number->string 0.99999 10 -6))++; check that we can get lots of digits of rational numbers, more than what a+; floating-point number could generate: #d1.45 is non-terminating in base 16:+; it is #x1.7333333... so it's easy to know what the result ought to be++(chk-run "#x1.7" '(number->string 145/100 16 1))+(chk-run "#x1.73" '(number->string 145/100 16 2))+(chk-run "#x1.733" '(number->string 145/100 16 3))+(chk-run "#x1.7333" '(number->string 145/100 16 4))+(chk-run "#x1.73333" '(number->string 145/100 16 5))+(chk-run "#x1.733333333333333" '(number->string 145/100 16 15))+(chk-run "#x1.7333333333333333333333333" '(number->string 145/100 16 25))+(chk-run "#x1.733333333333333333333333333333333333333333333333333333333333"+ '(number->string 145/100 16 60))+(chk-run "#x1.733333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333"+ '(number->string 145/100 16 120))++; and a larger number; comparison value was generated by a separate program++(chk-run "9.990020930143845079440327643300335909804291390541816917715293e30102"+ '(number->string (expt 2 100000) 10 -60))++(chk-run '#(a b c 1 2 3) '(list->vector '(a b c 1 2 3)))+(chk-run '(a b c 1 2 3) '(vector->list '#(a b c 1 2 3)))+(chk-run '#(a b c 1 2 3) '(vector 'a 'b 'c 1 2 3))+(chk-run '#(#f #f #f #f) '(make-vector 4))+(chk-run '#((a . b) (a . b) (a . b) (a . b)) '(make-vector 4 '(a . b)))+(chk-run 6 '(vector-length '#(a b c 1 2 3)))+(chk-run 8 '(vector-ref '#(1 1 2 3 5 8 13 21) 5))+(chk-run '#(0 "queen of the galaxy" "Barbarella")+ '(let ((vec (vector 0 '(2 2 2 2) "Barbarella")))+ (vector-set! vec 1 "queen of the galaxy")+ vec))+(chk-run '#("sexy" "sexy" "sexy")+ '(let ((vec (vector "bodacious" "sexy" "Barbarella")))+ (vector-fill! vec "sexy")+ vec))++; check quasi-quote and unquote stuff++(chk-run '(list 3 4) '`(list ,(+ 1 2) 4))++(chk-run '(list a (quote a)) '(let ((name 'a)) `(list ,name ',name)))++(chk-run '(a 3 4 5 6 b) '`(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b))++(chk-run '((foo 7) . cons) '`((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons))))++; This test doesn't return quite what R6RS says: the 2, 4, 3 are+; floating-point rather than int as they show++(chk-run '#(10 5 2.0 4.0 3.0 8) '`#(10 5 ,(sqrt 4) ,@(map sqrt '(16 9)) 8))++(chk-run '(foo foo foo) '(let ((name 'foo))+ `((unquote name name name))))++(chk-run '((foo) (foo) (foo)) '(let ((name '(foo)))+ `((unquote name name name))))++(chk-run '(foo foo foo) '(let ((name '(foo)))+ `((unquote-splicing name name name))))++(chk-run '`(foo (unquote (append x y) (sqrt 9)))+ '(let ((q '((append x y) (sqrt 9))))+ ``(foo ,,@q)))++(chk-run '(a `(b ,(+ 1 2) ,(foo 4 d) e) f)+ '`(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f))++(chk-run '(a `(b ,x ,'y d) e)+ '(let ((name1 'x)+ (name2 'y))+ `(a `(b ,,name1 ,',name2 d) e)))++; This test doesn't return quite what R6RS says: the trailing 3 is+; floating-point rather than int as they show++(chk-run '(foo (2 3 4 5) 3.0)+ '(let ((x '(2 3))+ (y '(4 5)))+ `(foo (unquote (append x y) (sqrt 9)))))++; This comes out right, but the quasi-quoted expression on the right ends+; up being equivalent in the sense of (eqv?) to all three of the expressions+; listed in R6RS; I'm not entirely sure that's a problem, however... the+; innards are sufficiently different that I am not quite sure it makes sense+; to make the distinction they do.++(chk-run '((1 2) 3 4 five 6) '(let ((a 3)) `((1 2) ,a ,4 ,'five 6)))++; if anything gets past the guard, it'll kill the self-test; so don't do that++(write-string "Now test exception-handling; this will write some random text\n\n")++(define (guard-test exception)+ (guard+ (err ((begin (write-string "exception is '")+ (if (string? err)+ (write-string err)+ (display err))+ (write-string "'... ")+ #f) #t)+ ((and (string? err) (string=? err "meh"))+ (write-string "caught 'meh'\n")+ "I am the 'meh'-catcher")+ ((and (string? err) (string=? err "barf"))+ (write-string "caught 'barf'... yuk!\n")+ -42)+ ((and (string? err) (string=? err "yahoo!"))+ (write-string "a little excitable today, aren't we...\n")+ "US$44.6billion")+ ((eqv? err '(1 2))+ (write-string "does not compute <dalek's head explodes>\n")+ "daleks rule! (until their heads blow off)"))+ (raise exception)))++(define (nested-guard exception)+ (guard+ (err (else (write-string "hah, wimpy inner guard didn't catch that one!\n")+ #f))+ (guard-test exception)))++(chk-run "I am the 'meh'-catcher" '(guard-test "meh"))+(chk-run -42 '(guard-test "barf"))+(chk-run "US$44.6billion" '(guard-test "yahoo!"))+(chk-run "daleks rule! (until their heads blow off)" '(guard-test '(1 2)))++(write-string "\nAgain, this time with nested guards\n\n")++(chk-run "I am the 'meh'-catcher" '(nested-guard "meh"))+(chk-run -42 '(nested-guard "barf"))+(chk-run "US$44.6billion" '(nested-guard "yahoo!"))+(chk-run "daleks rule! (until their heads blow off)" '(nested-guard '(1 2)))+(chk-run #f '(nested-guard "shazam"))++; check some vector error messages++(guard (err+ (else (write-string "caught vector error ") (display err) (newline)))+ (let ((vec (vector 0 '(2 2 2 2) "Barbarella")))+ (vector-set! vec 200 "queen of the galaxy")+ vec))++(write-string "\nEnd of exception-handling test\n")++; and summarize everything again++(write-string "\ntotal tests run:\t"+ (number->string n-tests)+ "\ntests failed:\t\t"+ (number->string n-fails)+ "\ntotal CPU time:\t\t"+ (number->string (cputime) 10 3)+ " seconds\n"+ "total elapsed time:\t"+ (number->string (- (epochtime) start) 10 3)+ " seconds\n"+ "test finished at\t"+ (localtime)+ #\linefeed)
+ stdlib.scm view
@@ -0,0 +1,441 @@+; Copyright 2008 Uwe Hollerbach <uh@alumni.caltech.edu>+; Portions of this were derived from Jonathan Tang's haskell+; tutorial "Write yourself a scheme in 48 hours" and are thus+; Copyright Jonathan Tang+; (but I can't easily tell anymore who originally wrote what)++; This file is part of haskeem.+; haskeem is free software; you can redistribute it and/or modify+; it under the terms of the GNU General Public License as published by+; the Free Software Foundation; either version 2 of the License, or+; (at your option) any later version.++; haskeem is distributed in the hope that it will be useful,+; but WITHOUT ANY WARRANTY; without even the implied warranty of+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+; GNU General Public License for more details.++; You should have received a copy of the GNU General Public License+; along with haskeem; if not, write to the Free Software+; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA++; $Id: stdlib.scm,v 1.33 2009-03-28 20:34:38 uwe Exp $++; The haskeem standard library++(define (caar pair) (car (car pair)))+(define (cadr pair) (car (cdr pair)))+(define (cdar pair) (cdr (car pair)))+(define (cddr pair) (cdr (cdr pair)))+(define (caaar pair) (car (car (car pair))))+(define (caadr pair) (car (car (cdr pair))))+(define (cadar pair) (car (cdr (car pair))))+(define (caddr pair) (car (cdr (cdr pair))))+(define (cdaar pair) (cdr (car (car pair))))+(define (cdadr pair) (cdr (car (cdr pair))))+(define (cddar pair) (cdr (cdr (car pair))))+(define (cdddr pair) (cdr (cdr (cdr pair))))+(define (caaaar pair) (car (car (car (car pair)))))+(define (caaadr pair) (car (car (car (cdr pair)))))+(define (caadar pair) (car (car (cdr (car pair)))))+(define (caaddr pair) (car (car (cdr (cdr pair)))))+(define (cadaar pair) (car (cdr (car (car pair)))))+(define (cadadr pair) (car (cdr (car (cdr pair)))))+(define (caddar pair) (car (cdr (cdr (car pair)))))+(define (cadddr pair) (car (cdr (cdr (cdr pair)))))+(define (cdaaar pair) (cdr (car (car (car pair)))))+(define (cdaadr pair) (cdr (car (car (cdr pair)))))+(define (cdadar pair) (cdr (car (cdr (car pair)))))+(define (cdaddr pair) (cdr (car (cdr (cdr pair)))))+(define (cddaar pair) (cdr (cdr (car (car pair)))))+(define (cddadr pair) (cdr (cdr (car (cdr pair)))))+(define (cdddar pair) (cdr (cdr (cdr (car pair)))))+(define (cddddr pair) (cdr (cdr (cdr (cdr pair)))))++; TODO: This is a hack: it looks (and, indeed, it is) quite idiotic,+; but it's the right thing: "eval" is currently a special form in+; haskeem, so "(eval foo)" works, but (map eval (list foo)) fails+; (without this hack). In the latter expression, "eval" is seen as an+; unbound variable; well, this binds it to the right thing. I have to+; figure out how to fix this...++(define (eval x) (eval x))++; ditto for force++(define (force x) (force x))++; TODO: this should be a syntactic form, so that it can print out not just+; "assertion failure!" but what the expression was that failed++(define (assert x) (if x x (raise "assertion failure!")))++(define (append lst . lsts)+ (foldl (lambda (l1 l2) (foldr cons l2 l1)) lst lsts))++; This is defined this way, rather than as (map proc . lsts), so that+; the machinery will check that there is at least one list argument:+; just plain (map proc) is illegal.++(define (map proc lst . lsts)+ (set! lsts (append (list lst) lsts))+ (letrec ((m1 (lambda (func l1)+ (if (null? l1)+ '()+ (cons (func (car l1)) (m1 func (cdr l1)))))))+ (set! lst (m1 length lsts))+ (if (/= (apply min lst) (apply max lst))+ (raise "map: unequal list lengths"))+ (letrec ((m2 (lambda (l2)+ (if (null? (car l2))+ '()+ (cons (apply proc (m1 car l2)) (m2 (m1 cdr l2)))))))+ (m2 lsts))))++(define (flip func) (lambda (arg1 arg2) (func arg2 arg1)))++(define (foldr func end lst)+ (if (null? lst)+ end+ (func (car lst) (foldr func end (cdr lst)))))++(define (foldl func accum lst)+ (if (null? lst)+ accum+ (foldl func (func accum (car lst)) (cdr lst))))++(define (curry func arg1) (lambda args (apply func (append (list arg1) args))))++(define (compose f g) (lambda args (apply f (apply g args))))++(define fcdr (compose force cdr))++(define (unzip lst)+ (letrec*+ ((cars '())+ (cdrs '())+ (iter (lambda (l)+ (if (null? l)+ (list (reverse cars) (reverse cdrs))+ (begin (set! cars (cons (caar l) cars))+ (set! cdrs (cons (cadar l) cdrs))+ (iter (cdr l)))))))+ (iter lst)))++; Generate a list of n repetitions of c++(define (replicate c n)+ (if (<= n 0)+ '()+ (cons c (replicate c (- n 1)))))++; Generate a list of the numbers s, s+1, s+2, ... upto s+n-1++(define (upfrom s n)+ (if (<= n 0)+ '()+ (cons s (upfrom (+ s 1) (- n 1)))))++; This is taken from some SRFI, I don't recall which one.+; Generate a list of n values, index i >= 0 and i < n,+; where the ith value is computed by (proc i)++(define (list-tabulate n proc)+ (let ((acc '())+ (i (- n 1)))+ (do ((i (- n 1) (- i 1)))+ ((negative? i) acc)+ (set! acc (cons (proc i) acc)))))++(define (list-unhead lst n)+ (if (and (list? lst) (number? n))+ (list-tail lst (- (length lst) n))+ (raise "list-unhead expects a list and a number!")))++(define (list-untail lst n)+ (if (and (list? lst) (number? n))+ (list-head lst (- (length lst) n))+ (raise "list-untail expects a list and a number!")))++; return all elements of a list except the nth (counting from 0)++(define (list-unref lst n)+ (cond ((negative? n) lst)+ ((zero? n) (cdr lst))+ (else (append (list-head lst n) (list-tail lst (+ n 1))))))++(define (filter pred lst)+ (foldr (lambda (x y) (if (pred x) (cons x y) y)) '() lst))++(define (partition pred lst)+ (letrec* ((true-vals '())+ (false-vals '())+ (iter (lambda (l)+ (if (null? l)+ (list (reverse true-vals) (reverse false-vals))+ (begin (if (pred (car l))+ (set! true-vals (cons (car l) true-vals))+ (set! false-vals (cons (car l) false-vals)))+ (iter (cdr l)))))))+ (iter lst)))++(define (memp test? lst)+ (cond ((null? lst) #f)+ ((test? (car lst)) lst)+ (else (memp test? (cdr lst)))))++(define (memv obj lst) (memp (lambda (x) (eqv? x obj)) lst))++(define (assp test? lst)+ (cond ((null? lst) #f)+ ((test? (caar lst)) (car lst))+ (else (assp test? (cdr lst)))))++(define (assv obj lst) (assp (lambda (x) (eqv? x obj)) lst))++; merge-sort "lst" using comparison function "cmp"+; this is a stable sort as required by R6RS++(define (list-sort is-lt? lst)+ (letrec* ((aux-mrg (lambda (lst1 lst2)+ (cond ((null? lst1) lst2)+ ((null? lst2) lst1)+ ((is-lt? (car lst2) (car lst1))+ (cons (car lst2) (aux-mrg lst1 (cdr lst2))))+ (else+ (cons (car lst1) (aux-mrg (cdr lst1) lst2))))))+ (aux-srt (lambda (lt)+ (let* ((len (length lt))+ (half (quotient len 2)))+ (if (<= len 1)+ lt+ (aux-mrg (aux-srt (list-head lt half))+ (aux-srt (list-tail lt half))))))))+ (if (list? lst)+ (aux-srt lst)+ (raise "list-sort expects a list!"))))++(define (list-drop-while drop? lst)+ (if (and (> (length lst) 0) (drop? (car lst)))+ (list-drop-while drop? (cdr lst))+ lst))++(define (list-take-while keep? lst)+ (letrec ((tw (lambda (l a)+ (if (and (> (length l) 0) (keep? (car l)))+ (tw (cdr l) (cons (car l) a))+ (list (reverse a) l)))))+ (tw lst '())))++(define (find proc lst)+ (cond ((null? lst) #f)+ ((proc (car lst)) (car lst))+ (else (find proc (cdr lst)))))++; This is defined this way, rather than as (for-each proc . lsts), so+; that the machinery will check that there is at least one list argument:+; just plain (for-each proc) is illegal.++(define (for-each proc lst . lsts)+ (set! lsts (append (list lst) lsts))+ (set! lst (map length lsts))+ (if (/= (apply min lst) (apply max lst))+ (raise "for-each: unequal list lengths"))+ (letrec ((doit (lambda (ls)+ (if (null? (car ls))+ #t+ (begin (apply proc (map car ls))+ (doit (map cdr ls)))))))+ (doit lsts)))++; Ditto for this routine++(define (vector-for-each proc vec . vecs)+ (set! vecs (append (list vec) vecs))+ (set! vec (map vector-length vecs))+ (if (/= (apply min vec) (apply max vec))+ (raise "vector-for-each: unequal vector lengths"))+ (let* ((len (car vec))+ (res (make-vector len)))+ (do ((i 0 (+ i 1)))+ ((= i len) res)+ (vector-set! res i+ (apply proc (map (lambda (v) (vector-ref v i)) vecs))))))++; This takes either a single list-of-lists, ie, ((1 2) (a b)) which means+; do all combinations of items from the set [1,2] and of items from the set+; [a,b], or multiple lists of the individual sets; in the latter case, it's+; required to specify the empty list as the first arg, in order to avoid+; confusing the case where ((1 2) (a b)) means "first do the vector-valued+; arg (1 2), then do the vector-valued arg (a b)".+;+; (for-all-combinations proc '((1 2) (a b))) => (1 a) (1 b) (2 a) (2 b)+; (for-all-combinations proc '() '(1 2) '(a b)) => (1 a) (1 b) (2 a) (2 b)+;+; note one more level of parentheses compared to the first case+;+; (for-all-combinations proc '(((1 2) (a b)))) => (1 2) (a b)+;+; note that the last list is the same as in the first case:+; this is why the '() is needed+;+; (for-all-combinations proc '() '((1 2) (a b))) => (1 2) (a b)++(define (for-all-combinations proc lst . lsts)+ (if (eqv? (null? lst) (null? lsts))+ (raise "for-all-combinations: bad args"))+ (if (null? lst)+ (set! lst lsts))+ (cond ((null? lst) #f)+ ((= 1 (length lst))+ (for-each proc (car lst)))+ (else+ (for-each+ (lambda (x) (for-all-combinations (curry proc x) (cdr lst)))+ (car lst)))))++(define (string-split-by drop? str)+ (letrec ((aux-sb (lambda (l a)+ (let* ((proto+ (list-take-while (lambda (c) (not (drop? c))) l))+ (rest (list-drop-while drop? (cadr proto)))+ (app (cons (char->string (car proto)) a)))+ (if (zero? (length rest))+ (reverse app)+ (aux-sb rest app))))))+ (aux-sb (list-drop-while drop? (string->char str)) '())))++(define (string-join-by join . strs)+ (if (list? (car strs)) (set! strs (car strs)))+ (let* ((jc (string->char join))+ (joiner (lambda (str1 str2)+ (cond ((= (length str2) 0) str1)+ ((= (length str1) 0) str2)+ (else (append str1 jc str2))))))+ (char->string (foldl joiner '() (map string->char strs)))))++(define (expmod a n m)+ (cond ((negative? n) (raise "expmod needs a non-negative exponent"))+ ((zero? n) (modulo 1 m))+ ((even? n) (expmod (modulo (* a a) m) (/ n 2) m))+ (else (modulo (* a (expmod a (- n 1) m)) m))))++; This doesn't necessarily belong in the standard library... but it's fun :-)+; Lucas-Lehmer test for primality of Mersenne numbers:+; let p be a prime > 2, and define+;+; M_p = 2^p - 1+; s_i = 4 if i == 0+; s_{i-1}^2 - 2 otherwise+;+; then M_p is prime IFF s_{p-2} = 0 mod M_p++(define (mersenne-prime? e)+ (if (= e 2)+ #t+ (letrec* ((candidate (- (expt 2 e) 1))+ (loop (lambda (s c)+ (if (zero? c)+ s+ (loop (modulo (- (* s s) 2) candidate) (- c 1))))))+ (zero? (modulo (loop 4 (- e 2)) candidate)))))++; like list-head, except we force the cdr of the stream before recursing,+; so that there will be a there there; also, we don't test for list-ness,+; because a stream is a dotted-pair composed of a value and a promise,+; not a real list++(define (stream-head strm n)+ (if (<= n 0)+ '()+ (cons (car strm) (stream-head (fcdr strm) (- n 1)))))++(define (stream-map func str . strs)+ (set! strs (append (list str) strs))+ (letrec ((m1 (lambda (fn l1)+ (if (null? l1)+ '()+ (cons (fn (car l1)) (m1 fn (cdr l1))))))+ (m2 (lambda (ls)+ (cons (apply func (m1 car ls))+ (delay (m2 (m1 fcdr ls)))))))+ (m2 strs)))++; scale a stream by a number; this optimizes the 0 and 1 cases, although+; the former does assume that there are no infinities in the stream; if+; there were any, they should properly get turned into NaNs.++(define (stream-scale scale strm)+ (cond ((zero? scale) (letrec ((z (cons 0 (delay z)))) z))+ ((= 1 scale) strm)+ (else (cons (* scale (car strm))+ (delay (stream-scale scale (fcdr strm)))))))++; stream-take-while: analogous to list-take-while, except it doesn't+; check the length of the list, and it forces the cdr so that there+; will be a there there when we look at it.++(define (stream-take-while keep? strm)+ (letrec ((tw (lambda (s a)+ (if (keep? (car s))+ (tw (fcdr s) (cons (car s) a))+ (list (reverse a) s)))))+ (tw strm '())))++; exact integer sqrt returns a two-element list: A -> (SA R) where+; A = SA^2 + R, 0 <= R <= 2*SA+; it proceeds via Newton-Raphson iteration from a good initial guess at+; the square root++(define (exact-integer-sqrt A)+ (cond ((negative? A) (raise "negative input to exact-integer-sqrt"))+ ((zero? A) '(0 0))+ ((= A 1) '(1 0))+ (else (letrec* ((x0 (expt 2 (ceiling (/ (ilog A) 2))))+ (xn 0)+ (sq (lambda (x) (* x x)))+ (iter (lambda (xo)+ (set! xn (floor (/ (+ A (sq xo)) (* 2 xo))))+ (when (< 1 (abs (- xn xo)))+ (iter xn))+ (set! xo (- A (sq xn)))+ (when (negative? xo)+ (set! xn (- xn 1))+ (set! xo (- A (sq xn))))+ (list xn xo))))+ (iter x0)))))++; Exact integer cbrt returns a two-element list: A -> (CA R) where+; A = CA^3 + R, CA = trunc of exact cube root and R has the same sign+; as CA. It proceeds via Newton-Raphson iteration from a good initial guess+; at the cube root.++(define (exact-integer-cbrt A)+ (cond ((negative? A) (map - (exact-integer-cbrt (- A))))+ ((zero? A) '(0 0))+ ((= A 1) '(1 0))+ (else (letrec* ((x0 (expt 2 (ceiling (/ (ilog A) 3))))+ (xn 0)+ (sq (lambda (x) (* x x)))+ (cb (lambda (x) (* x x x)))+ (iter (lambda (xo)+ (set! xn (floor (/ (+ A (* 2 (cb xo)))+ (* 3 (sq xo)))))+ (when (< 1 (abs (- xn xo)))+ (iter xn))+ (set! xo (- A (cb xn)))+ (when (negative? xo)+ (set! xn (- xn 1))+ (set! xo (- A (cb xn))))+ (list xn xo))))+ (iter x0)))))++(define (newline . port)+ (if (zero? (length port))+ (write-string #\linefeed)+ (write-string (car port) #\linefeed)))++; if desired, this can be enabled; that's a nice confirmation in the REPL+; that everything is ok++; (write-string "stdlib loaded ok\n")