diff --git a/Environment.hs b/Environment.hs new file mode 100644 --- /dev/null +++ b/Environment.hs @@ -0,0 +1,74 @@ +{- Copyright 2008 Uwe Hollerbach +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 diff --git a/Evaluator.hs b/Evaluator.hs new file mode 100644 --- /dev/null +++ b/Evaluator.hs @@ -0,0 +1,756 @@ +{- Copyright 2008 Uwe Hollerbach +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) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + + + Copyright (C) + + 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. + + , 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. diff --git a/Library.hs b/Library.hs new file mode 100644 --- /dev/null +++ b/Library.hs @@ -0,0 +1,1483 @@ +{- Copyright 2008 Uwe Hollerbach +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 "" "character" notChar + +unpackIntNum :: LispVal -> ThrowsError Integer +unpackIntNum (IntNumber n) = return n +unpackIntNum (RatNumber n) = + if (denominator n) /= 0 + then return (truncate n) + else errTypeMismatch "" "number" (RatNumber n) +unpackIntNum (FltNumber n) = return (truncate n) +unpackIntNum (List [n]) = unpackIntNum n +unpackIntNum notNum = errTypeMismatch "" "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 "" "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 "" "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 "" "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<=?" (<=)), + ("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) diff --git a/LispData.hs b/LispData.hs new file mode 100644 --- /dev/null +++ b/LispData.hs @@ -0,0 +1,189 @@ +{- Copyright 2008 Uwe Hollerbach +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 _) = "" +showVal (Func {params = args, vararg = varargs, body = _, closure = _}) = + "(lambda (" ++ (unwords args) ++ + (case varargs of + Nothing -> "" + Just arg -> " . " ++ arg) ++ ") ...)" +showVal (IOPrim _) = "" +showVal (Port _) = "" +showVal (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 = _}) = + "" ++ (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 diff --git a/Parser.hs b/Parser.hs new file mode 100644 --- /dev/null +++ b/Parser.hs @@ -0,0 +1,414 @@ +{- Copyright 2008 Uwe Hollerbach +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: +-- ' => (quote ) +-- ` => (quasiquote ) +-- , => (unquote ) +-- ,@ => (unquote-splicing ) + +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 diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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! diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +module Main where +import Distribution.Simple +main = defaultMain diff --git a/WriteNumber.hs b/WriteNumber.hs new file mode 100644 --- /dev/null +++ b/WriteNumber.hs @@ -0,0 +1,253 @@ +{- Copyright 2008 Uwe Hollerbach +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) diff --git a/fibo.scm b/fibo.scm new file mode 100644 --- /dev/null +++ b/fibo.scm @@ -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") diff --git a/gendoc.scm b/gendoc.scm new file mode 100644 --- /dev/null +++ b/gendoc.scm @@ -0,0 +1,67 @@ +; Copyright 2008 Uwe Hollerbach + +; 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) (stringstring (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 "")) + (write-string ", returns ") + (if ret + (display (cdr ret)) + (write-string "")) + (write-string #\linefeed))) + +(define section) + +(map show doc-data) diff --git a/guard.scm b/guard.scm new file mode 100644 --- /dev/null +++ b/guard.scm @@ -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))) diff --git a/hamming.scm b/hamming.scm new file mode 100644 --- /dev/null +++ b/hamming.scm @@ -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) diff --git a/haskeem.cabal b/haskeem.cabal new file mode 100644 --- /dev/null +++ b/haskeem.cabal @@ -0,0 +1,26 @@ +Name: haskeem +Version: 0.6.10 +Author: Uwe Hollerbach +Maintainer: Uwe Hollerbach +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 diff --git a/haskeem.doc b/haskeem.doc new file mode 100644 --- /dev/null +++ b/haskeem.doc @@ -0,0 +1,346 @@ +; Copyright 2008 Uwe Hollerbach + +; 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 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)) diff --git a/haskeem.hs b/haskeem.hs new file mode 100644 --- /dev/null +++ b/haskeem.hs @@ -0,0 +1,135 @@ +{- Copyright 2008 Uwe Hollerbach +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 \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 diff --git a/haskeem_readline.hs b/haskeem_readline.hs new file mode 100644 --- /dev/null +++ b/haskeem_readline.hs @@ -0,0 +1,159 @@ +{- Copyright 2008 Uwe Hollerbach +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 \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 diff --git a/powerseries.scm b/powerseries.scm new file mode 100644 --- /dev/null +++ b/powerseries.scm @@ -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))) diff --git a/primes.scm b/primes.scm new file mode 100644 --- /dev/null +++ b/primes.scm @@ -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)))) diff --git a/selftest.scm b/selftest.scm new file mode 100644 --- /dev/null +++ b/selftest.scm @@ -0,0 +1,2636 @@ +; Copyright 2008 Uwe Hollerbach + +; 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 #f '(string<=? "lesser" "greater")) + +(chk-run #t '(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 #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-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 ( ) version, without the + +(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 stringstring 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 \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) diff --git a/stdlib.scm b/stdlib.scm new file mode 100644 --- /dev/null +++ b/stdlib.scm @@ -0,0 +1,441 @@ +; Copyright 2008 Uwe Hollerbach +; 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")