haskeem 0.7.12 → 0.7.16
raw patch · 14 files changed
+1120/−1596 lines, 14 files
Files
- Environment.hs +16/−8
- Evaluator.hs +408/−358
- Library.hs +179/−152
- LispData.hs +79/−39
- Parser.hs +50/−48
- WriteNumber.hs +64/−67
- delTEST.scm +0/−642
- delcont.scm +25/−21
- deltest.scm +236/−243
- haskeem.cabal +1/−1
- haskeem.hs +7/−6
- haskeem_readline.hs +9/−8
- selftest.scm +21/−2
- stdlib.scm +25/−1
Environment.hs view
@@ -18,23 +18,25 @@ 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.12 2009-08-06 05:05:15 uwe Exp $ -}+$Id: environment.hs,v 1.14 2010-01-05 05:23:34 uwe Exp $ -} module Environment (isBound, getVar, setVar, defineVar, bindVars, dumpEnv) where import Prelude+import Data.Maybe import IO import Control.Monad.Error as CME import Data.IORef import LispData +liftRead :: MonadIO m => IORef a -> m a liftRead = liftIO . readIORef isBound :: Env -> String -> IO Bool isBound envRef var = do env <- liftIO (readIORef envRef)- return (maybe False (const True) (lookup var env))+ return (isJust (lookup var env)) getVar :: Env -> String -> IOThrowsError LispVal getVar envRef var =@@ -46,7 +48,7 @@ setVar envRef var value = do env <- liftRead envRef maybe (throwError (UnboundVar "Setting an unbound variable" var))- (liftIO . (flip writeIORef value))+ (liftIO . flip writeIORef value) (lookup var env) return value @@ -64,10 +66,16 @@ addBinding (var, value) = do ref <- newIORef value return (var, ref) -dumpEnv :: Env -> Handle -> IOThrowsError LispVal-dumpEnv envRef port = liftRead envRef >>= doDump+-- The lastkey argument is for internal debugging: pass a non-empty string+-- in, and the dump will stop before printing that symbol... useful for+-- shortening the output. Not currently accessible at the scheme level.++dumpEnv :: Env -> Handle -> String -> IOThrowsError LispVal+dumpEnv envRef port lastkey = liftRead envRef >>= doDump where doDump [] = return lispTrue doDump ((key, vref):vars) =- do val <- liftRead vref- liftIO (hPutStrLn port (key ++ " -> " ++ (show val)))- doDump vars+ if key == lastkey+ then return lispTrue+ else do val <- liftRead vref+ liftIO (hPutStrLn port (key ++ " -> " ++ show val))+ doDump vars
Evaluator.hs view
@@ -18,8 +18,10 @@ 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.40 2009-08-08 05:08:59 uwe Exp $ -}+$Id: evaluator.hs,v 1.51 2010-01-18 00:08:49 uwe Exp $ -} +{-# LANGUAGE FlexibleContexts #-}+ module Evaluator (evalLisp, evalPP) where import Prelude import IO@@ -32,24 +34,30 @@ 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))+errNumArgs :: MonadError LispError m =>+ String -> Integer -> [LispVal] -> m a+errNumArgs name want = throwError . NumArgs name want +errTypeMismatch :: MonadError LispError m =>+ String -> String -> LispVal -> m a+errTypeMismatch name want = throwError . TypeMismatch name want++errBadForm :: MonadError LispError m => String -> [LispVal] -> m a+errBadForm name =+ throwError . BadSpecial ("bad " ++ name ++ " form") . List+ -- Debugging output: either inside haskeem while tracing something, -- or inside haskeem while debugging haskeem -remark str = liftIO (hPutStrLn stderr str)--progError = error "internal error!"+remark :: MonadIO m => String -> m ()+remark = liftIO . hPutStrLn stderr -{-# INLINE mapML #-}+mapML :: Monad m => (a -> m LispVal) -> [a] -> m LispVal mapML fn lst = mapMLA (List []) fn lst where mapMLA r _ [] = return r- mapMLA ro fn (x:xs) =- do rn <- fn x- mapMLA rn fn xs+ mapMLA _ f (x:xs) =+ do rn <- f x+ mapMLA rn f xs isTrue :: LispVal -> Bool isTrue (Boolean False) = False@@ -60,9 +68,9 @@ uniqCheck :: String -> [LispVal] -> Bool uniqCheck _ [] = True-uniqCheck name ((List ((Symbol var):_)):rest) =+uniqCheck name ((List (Symbol var : _)) : rest) = if name == var then False else uniqCheck name rest-uniqCheck _ _ = progError+uniqCheck _ _ = progError "uniqCheck" -- Check the variable bindings in the various forms of "let". -- The "uniq" boolean argument specifies whether or not multiple@@ -70,8 +78,8 @@ letCheck :: Bool -> [LispVal] -> Bool letCheck _ [] = True-letCheck uniq ((List [Symbol var, _]):rest) =- letCheck uniq rest && ((not uniq) || (uniq && uniqCheck var rest))+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:@@ -79,9 +87,9 @@ doCheck :: [LispVal] -> Bool doCheck [] = True-doCheck ((List [Symbol var, _]):rest) =+doCheck ((List [Symbol var, _]) : rest) = doCheck rest && uniqCheck var rest-doCheck ((List [Symbol var, _, _]):rest) =+doCheck ((List [Symbol var, _, _]) : rest) = doCheck rest && uniqCheck var rest doCheck _ = False @@ -89,94 +97,134 @@ paramsCheck :: [LispVal] -> Bool paramsCheck [] = True-paramsCheck ((Symbol var):rest) =+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+ uC name (Symbol var2 : rmdr) =+ if name == var2 then False else uC name rmdr+ uC _ _ = progError "paramsCheck" paramsCheck _ = False -- This is the apply function, the generic -- omnipotent thing that does all the work doApply :: Bool -> String -> [String] -> (Maybe String) -> [LispVal]- -> Env -> [[LispVal]] -> Integer -> [LispVal]- -> IOThrowsError LispVal-doApply trace name params varargs body closure dcs ql args =+ -> Env -> EEnv -> [LispVal] -> Bool -> IOThrowsError LispVal+doApply trace name params varargs body closure eenv args cflag = 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+ else do let app = zip params args+ ca = head app+ prtTrace+ envn <- liftIO (bindVars closure app) >>= bindVarArgs varargs+ let een = eeNewE eenv envn+ eenc = eeNewPE een (ca : eePE een)+ evalBody (if cflag then eenc else een) where remainingArgs = drop (length params) args num = toInteger . length- evalBody env = mapML (evalLisp env dcs ql) body+ evalBody ee = mapML (evalLisp ee) body bindVarArgs arg env = case arg of Just argName ->- liftIO (bindVars env [(argName, List (remainingArgs))])+ liftIO (bindVars env [(argName, List remainingArgs)]) Nothing -> return env prtTrace = if trace- then remark ("trace: " ++ name ++ " <- " ++ (show (List args))) >>- return True+ then remark ("trace: " ++ name ++ " <- " ++ show (List args))+ >> return True else return False -apply :: [[LispVal]] -> Integer -> LispVal -> [LispVal]- -> IOThrowsError LispVal-apply _ _ (Prim func) args = liftThrows (func args)-apply _ _ (IOPrim func) args = func args-apply dcs ql (Func params varargs body closure Nothing _) args =- doApply False "" params varargs body closure dcs ql args-apply dcs ql (Func params varargs body closure (Just name) _) args =- doApply True name params varargs body closure dcs ql args-apply _ _ func _ = throwError (NotFunction "apply got non-function" func)+apply :: EEnv -> LispVal -> [LispVal] -> IOThrowsError LispVal+apply _ (Prim func) args = liftThrows (func args)+apply _ (IOPrim func) args = func args+apply eenv (Func params varargs body closure Nothing _ cflag) args =+ doApply False "" params varargs body closure eenv args cflag+apply eenv (Func params varargs body closure (Just name) _ cflag) args =+ doApply True name params varargs body closure eenv args cflag+apply _ func _ = throwError (NotFunction "apply got non-function" func) -makeFunc varargs env params body =- return (Func (map show params) varargs body env Nothing False)-makeNormalFunc = makeFunc Nothing-makeVarargsFunc = makeFunc . Just . show+makeFunc, makeMacro ::+ Monad m => Maybe String -> Env -> [LispVal] -> [LispVal] -> m LispVal +makeFunc varargs env params body =+ return (Func (map show params) varargs body env Nothing False False) makeMacro varargs env params body =- return (Func (map show params) varargs body env Nothing True)+ return (Func (map show params) varargs body env Nothing True False)++makeNormalFunc, makeNormalMacro ::+ Monad m => Env -> [LispVal] -> [LispVal] -> m LispVal++makeNormalFunc = makeFunc Nothing makeNormalMacro = makeMacro Nothing++makeVarargsFunc, makeVarargsMacro ::+ Monad m => LispVal -> Env -> [LispVal] -> [LispVal] -> m LispVal++makeVarargsFunc = makeFunc . Just . show makeVarargsMacro = makeMacro . Just . show +makeContFunc :: Monad m => Env -> [LispVal] -> [LispVal] -> m LispVal+makeContFunc env params body =+ return (Func (map show params) Nothing body env Nothing False True)++specialForms :: [String] specialForms = ["and", "apply", "begin", "case", "cond", "define", "defmacro", "delay", "do", "eval", "force", "gensym", "guard", "if", "lambda", "let", "let*", "letrec", "letrec*", "load", "or", "quasiquote", "quote", "set!", "unquote", "unquote-splicing", "vector-fill!",- "vector-set!", "ext cont", "int cont",+ "vector-set!", "reset", "shift ", "trace", "dump-bindings"] -isSpecialForm (Symbol s) = seek s specialForms+isSpecialForm, isInt, isStr, isList, isDL, isVec :: LispVal -> Bool++isSpecialForm (Symbol sym) = seek sym specialForms where seek _ [] = False- seek s (sf:sfs) = if s == sf then True else seek s sfs+ seek s (sf:sfs) = (s == sf) || seek s sfs isSpecialForm _ = False isInt (IntNumber _) = True isInt _ = False++getInt :: LispVal -> Integer getInt (IntNumber n) = n+getInt _ = progError "getInt" isStr (String _) = True isStr _ = False++getStr :: LispVal -> String getStr (String s) = s+getStr _ = progError "getStr" isList (List _) = True isList _ = False++getList :: LispVal -> [LispVal] getList (List l) = l+getList _ = progError "getList" isDL (DottedList _ _) = True isDL _ = False++getDLh :: LispVal -> [LispVal] getDLh (DottedList h _) = h+getDLh _ = progError "getDLh"++getDLt :: LispVal -> LispVal getDLt (DottedList _ t) = t+getDLt _ = progError "getDLt" isVec (Vector _ _) = True isVec _ = False++getVecL :: LispVal -> Integer getVecL (Vector l _) = l+getVecL _ = progError "getVecL"++getVecV :: LispVal -> DIM.IntMap LispVal getVecV (Vector _ v) = v+getVecV _ = progError "getVecV" -- This is an internal symbol which temporarily replaces "unquote" and -- "unquote-splicing" after these have evaluated the expression(s): evalQQ@@ -205,7 +253,7 @@ liftSUnq :: LispVal -> IOThrowsError LispVal liftSUnq l@(List ((Symbol sym):vals)) = if sym == unq- then if (length vals) == 1+ then if length vals == 1 then return (head vals) else throwError (Default "list unquote form in scalar context") else return l@@ -216,126 +264,109 @@ -- or an unquote-splicing at the right quote level; these it evaluates via -- evalLisp and patches into the tree -evalQQ :: Env -> [[LispVal]] -> Integer -> LispVal -> IOThrowsError LispVal+evalQQ :: EEnv -> LispVal -> IOThrowsError LispVal -- "quasiquote", "unquote", and "unquote-splicing" might get evaluated, -- depending on quote level -evalQQ env dcs ql (List [Symbol "quasiquote", arg]) =- do val <- evalQQ env dcs (ql + 1) arg >>= liftSUnq+evalQQ eenv (List [Symbol "quasiquote", arg]) =+ do val <- evalQQ (eeQLIncr eenv) arg >>= liftSUnq return (List [Symbol "quasiquote", val]) -evalQQ env dcs ql (List (Symbol "unquote" : args)) =- if ql == 1- then do vals <- mapM (evalLisp env dcs 0) args- return (List ((Symbol unq):vals))- else do vals <- mapM (evalQQ env dcs (ql - 1)) args- return (List ((Symbol "unquote") : (liftLUnq vals)))+evalQQ eenv (List (Symbol "unquote" : args)) =+ let een = eeQLDecr eenv+ in if eeQL eenv == 1+ then do vals <- mapM (evalLisp een) args+ return (List (Symbol unq : vals))+ else do vals <- mapM (evalQQ een) args+ return (List (Symbol "unquote" : liftLUnq vals)) -evalQQ env dcs ql (List (Symbol "unquote-splicing" : args)) =- if ql == 1- then do vals <- mapM (evalLisp env dcs 0) args- if isLL vals- then return (List ((Symbol unq):(peel vals)))- else throwError (Default ("bad unquote-splicing form: " ++- (show args)))- else do vals <- mapM (evalQQ env dcs (ql - 1)) args- return (List ((Symbol "unquote-splicing") : (liftLUnq vals)))+evalQQ eenv (List (Symbol "unquote-splicing" : args)) =+ let een = eeQLDecr eenv+ in if eeQL eenv == 1+ then do vals <- mapM (evalLisp een) args+ if isLL vals+ then return (List (Symbol unq : peel vals))+ else throwError (Default ("bad unquote-splicing form: " +++ show args))+ else do vals <- mapM (evalQQ een) args+ return (List (Symbol "unquote-splicing" : liftLUnq vals)) where isLL [] = True isLL ((List _):ls) = isLL ls isLL _ = False peel [] = []- peel ((List l):ls) = l ++ (peel ls)+ peel ((List l):ls) = l ++ peel ls+ peel _ = progError "evalQQ/unquote-splicing" -- lists, dotted-lists, and vectors get traversed -evalQQ env dcs ql (List con) =- mapM (evalQQ env dcs ql) con >>= return . List . liftLUnq+evalQQ eenv (List con) = mapM (evalQQ eenv) con >>= return . List . liftLUnq -evalQQ env dcs ql (DottedList con cab) =- do vals <- mapM (evalQQ env dcs ql) con- vcab <- evalQQ env dcs ql cab >>= liftSUnq- let head = liftLUnq vals+evalQQ eenv (DottedList con cab) =+ do vals <- mapM (evalQQ eenv) con+ vcab <- evalQQ eenv cab >>= liftSUnq+ let h = liftLUnq vals if isList vcab- then return (List (head ++ (getList vcab)))+ then return (List (h ++ getList vcab)) else if isDL vcab- then return (DottedList (head ++ (getDLh vcab)) (getDLt vcab))- else return (DottedList head vcab)+ then return (DottedList (h ++ getDLh vcab) (getDLt vcab))+ else return (DottedList h vcab) -evalQQ env dcs ql (Vector _ con) =- do vals <- mapM (evalQQ env dcs ql) (remkey (DIM.toAscList con))+evalQQ eenv (Vector _ con) =+ do vals <- mapM (evalQQ eenv) (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)+ remkey ((_, v) : vs) = v : remkey vs addkey _ [] = []- addkey n (v:vs) = (n, v):(addkey (n+1) vs)+ addkey n (v:vs) = (n, v) : addkey (n+1) vs -- anything else gets returned unchanged -evalQQ _ _ _ val@_ = return val+evalQQ _ val@_ = return val -- evalPP is another specialized version of evalLisp: it also walks -- the tree and turns the del-cont operators into their internal form,--- which has a unique identifier and possibly two flags attached. The--- unique identifier is to be able to identify which is the current--- hole in an expression if there are several interior operators--- enclosed within the scope of an exterior operator. The flags are to--- determine whether or not to attach the two new reset operators--- during the transformation.+-- which has a unique identifier attached. The unique identifier is to+-- be able to identify which is the current hole in an expression if+-- there are several interior operators enclosed within the scope of+-- an exterior operator. --- TODO: check shift etc operators for syntactic correctness here?+-- TODO: check shift operators for syntactic correctness here? -- ie, check that the first arg is a symbol and not something else? -- probably a good idea... --- TODO: temporarily make this code deal with ALL-CAPS versions of--- reset et al; otherwise, we break all of the delcont/deltest stuff--evalPP :: Env -> LispVal -> IOThrowsError LispVal+evalPP :: EEnv -> LispVal -> IOThrowsError LispVal -evalPP env (List ((Symbol sym):arg)) =- do argn <- mapM (evalPP env) arg- if sym == "RESET" || sym == "PROMPT" ||- sym == "RESET0" || sym == "PROMPT0" ||- sym == "SHIFT" || sym == "CONTROL" ||- sym == "SHIFT0" || sym == "CONTROL0"- then do newsym <- transmogrify- return (List (newsym ++ argn))- else return (List ((Symbol sym) : argn))- where transmogrify =- do cval <- getVar env contCounter- let count = getInt cval- csym = " cont." ++ (show count)- f0 = (sym == "RESET" || sym == "PROMPT" ||- sym == "RESET0" || sym == "PROMPT0")- f1 = (sym == "SHIFT" || sym == "SHIFT0")- f2 = (sym == "SHIFT" || sym == "CONTROL")- do setVar env contCounter (IntNumber (count + 1))- return (if f0- then [Symbol "ext cont", Symbol csym]- else [Symbol "int cont", Symbol csym,- Boolean f1, Boolean f2])+evalPP eenv (List (Symbol "shift" : arg)) =+ do let env = eeE eenv+ argn <- mapM (evalPP eenv) arg+ cval <- getVar env contCounter+ let count = getInt cval+ csym = " cont." ++ show count+ setVar env contCounter (IntNumber (count + 1))+ return (List (Symbol "shift " : Symbol csym : argn)) -evalPP env (List args) = mapM (evalPP env) args >>= return . List+evalPP eenv (List args) = mapM (evalPP eenv) args >>= return . List -- everything else gets returned unchanged -evalPP env val = return val+evalPP _ val = return val -- This is the main evaluator -evalLisp :: Env -> [[LispVal]] -> Integer -> LispVal -> IOThrowsError LispVal+evalLisp :: EEnv -> 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@(Boolean _) = return val-evalLisp _ _ _ val@(Char _) = return val-evalLisp _ _ _ (List []) = return (List [])-evalLisp env _ _ (Symbol id) = getVar env id+evalLisp _ val@(String _) = return val+evalLisp _ val@(IntNumber _) = return val+evalLisp _ val@(RatNumber _) = return val+evalLisp _ val@(FltNumber _) = return val+evalLisp _ val@(Boolean _) = return val+evalLisp _ val@(Char _) = return val+evalLisp _ (List []) = return (List [])+evalLisp eenv (Symbol ident) = getVar (eeE eenv) ident -- Special forms must go here, before the generic (function : args) stuff @@ -345,12 +376,13 @@ -- convenient to have it here; otherwise, we have to do all sorts of -- twisting to make it all work. -evalLisp env dcs ql (List (Symbol "apply" : function : args)) =- do func <- evalLisp env dcs ql function- argVals <- mapM (evalLisp env dcs ql) args+evalLisp eenv (List (Symbol "apply" : fn : args)) =+ do func <- evalLisp eenv fn+ argVals <- mapM (evalLisp eenv) args appp (func:argVals)- where appp [func, List args] = apply dcs ql func args- appp (func : args) = apply dcs ql func args+ where appp [f, List as] = apply eenv f as+ appp (f : as) = apply eenv f as+ appp _ = progError "evalLisp/apply" -- 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@@ -363,10 +395,8 @@ -- move this into the libraries... I'd just have to provide access to -- the (or a) top-level environment. -evalLisp env dcs ql (List (Symbol "eval" : args)) =- mapM (evalPP env) args >>=- mapM (evalLisp env dcs ql) >>=- mapML (evalLisp env dcs ql)+evalLisp eenv (List (Symbol "eval" : args)) =+ mapM (evalPP eenv) args >>= mapM (evalLisp eenv) >>= mapML (evalLisp eenv) -- 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@@ -375,294 +405,305 @@ -- wants to (or should be able to) call (load) from within some -- function and modify the environment seen within that function. -evalLisp env dcs ql (List [Symbol "load", arg]) =- do fname <- evalLisp env dcs ql arg+evalLisp eenv (List [Symbol "load", arg]) =+ do fname <- evalLisp eenv arg if isStr fname then loadFile (getStr fname) >>=- mapM (evalPP env) >>=- mapML (evalLisp env dcs ql)+ mapM (evalPP eenv) >>= mapML (evalLisp eenv) else throwError (Default ("bad load form: " ++- (show fname) ++ " is not a string"))+ show fname ++ " is not a string")) -evalLisp env dcs ql (List (Symbol "begin" : args)) =- mapML (evalLisp env dcs ql) args+evalLisp eenv (List (Symbol "begin" : args)) = mapML (evalLisp eenv) args -evalLisp _ _ _ (List [Symbol "quote", val]) = return val+evalLisp _ (List [Symbol "quote", val]) = return val -evalLisp env dcs ql (List [Symbol "quasiquote", val]) =- evalQQ env dcs (ql + 1) val >>= liftSUnq+evalLisp eenv (List [Symbol "quasiquote", val]) =+ evalQQ (eeQLIncr eenv) val >>= liftSUnq -evalLisp _ _ _ (List (Symbol "unquote" : args)) =- throwError (Default ("naked unquote form: " ++ (show args)))+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 _ (List (Symbol "unquote-splicing" : args)) =+ throwError (Default ("naked unquote-splicing form: " ++ show args)) -evalLisp env dcs ql (List [Symbol "set!", Symbol var, val]) =- evalLisp env dcs ql val >>= setVar env var+evalLisp eenv (List [Symbol "set!", Symbol var, val]) =+ evalLisp eenv val >>= setVar (eeE eenv) var -evalLisp env dcs ql (List [Symbol "vector-set!", Symbol var, indx, obj]) =- do vec <- evalLisp env dcs ql (Symbol var)+evalLisp eenv (List [Symbol "vector-set!", Symbol var, indx, obj]) =+ do vec <- evalLisp eenv (Symbol var) if isVec vec- then do lk <- evalLisp env dcs ql indx+ then do lk <- evalLisp eenv indx let l = getVecL vec k = getInt lk- if ((isInt lk) && k >= 0 && k < l)- then do val <- evalLisp env dcs ql obj- setVar env var (Vector l+ if isInt lk && k >= 0 && k < l+ then do val <- evalLisp eenv obj+ setVar (eeE eenv) var (Vector l (DIM.insert (fromInteger k) val (getVecV vec))) else throwError (VectorBounds l lk) else throwError (Default ("bad vector-set! form: " ++- (show var) ++ " is not a vector"))+ show var ++ " is not a vector")) -evalLisp env dcs ql (List [Symbol "vector-fill!", Symbol var, obj]) =- do vec <- evalLisp env dcs ql (Symbol var)+evalLisp eenv (List [Symbol "vector-fill!", Symbol var, obj]) =+ do vec <- evalLisp eenv (Symbol var) if isVec vec- then do val <- evalLisp env dcs ql obj+ then do val <- evalLisp eenv obj let n = getVecL vec- setVar env var (Vector n (DIM.fromAscList+ setVar (eeE eenv) var (Vector n (DIM.fromAscList (addkey val (fromInteger n)))) else throwError (Default ("bad vector-fill! form: " ++- (show var) ++ " is not a vector"))+ show var ++ " is not a vector")) where addkey _ 0 = []- addkey v n = ((n-1), v):(addkey v (n-1))+ addkey v n = ((n-1), v) : addkey v (n-1) -evalLisp env dcs ql (List [Symbol "vector-resize!", Symbol var, obj]) =- do vec <- evalLisp env dcs ql (Symbol var)+evalLisp eenv (List [Symbol "vector-resize!", Symbol var, obj]) =+ do vec <- evalLisp eenv (Symbol var) if isVec vec- then do lk <- evalLisp env dcs ql obj+ then do lk <- evalLisp eenv obj let l = getVecL vec k = getInt lk- if (isInt lk) && (k > 0)+ if isInt lk && k > 0 then do let new = if k < l- then rem (getVecV vec) l k+ then rmv (getVecV vec) l k else add (getVecV vec) k l- setVar env var (Vector k new)+ setVar (eeE eenv) var (Vector k new) else throwError (Default ("bad vector-resize! size: " ++- (show k)))+ show k)) else throwError (Default ("bad vector-resize! form: " ++- (show var) ++ " is not a vector"))- where rem vec h l =+ show var ++ " is not a vector"))+ where rmv vec h l = if h == l then vec- else rem (DIM.delete (fromInteger l) vec) h (l + 1)+ else rmv (DIM.delete (fromInteger l) vec) h (l + 1) add vec h l = if h == l then vec else add (DIM.insert (fromInteger l) lispFalse vec) h (l + 1) -evalLisp env dcs ql (List [Symbol "define", Symbol var, val]) =- do defineVar env var lispFalse- evalLisp env dcs ql val >>= setVar env var-evalLisp env _ _ (List [Symbol "define", Symbol var]) =- defineVar env var lispFalse-evalLisp env dcs _+evalLisp eenv (List [Symbol "define", Symbol var, val]) =+ do let env = eeE eenv+ defineVar env var lispFalse+ evalLisp eenv val >>= setVar env var+evalLisp eenv (List [Symbol "define", Symbol var]) =+ defineVar (eeE eenv) var lispFalse+evalLisp (EEnv env _ _ _) (List (Symbol "define" : List (Symbol var : params) : body)) = if paramsCheck params then do defineVar env var lispFalse makeNormalFunc env params body >>= setVar env var else errBadForm "define" params-evalLisp env dcs _ (List (Symbol "define" :+evalLisp (EEnv env _ _ _) (List (Symbol "define" : DottedList (Symbol var : params) varargs : body)) = if paramsCheck (params ++ [varargs]) then do defineVar env var lispFalse makeVarargsFunc varargs env params body >>= setVar env var else errBadForm "define" [DottedList params varargs] -evalLisp env dcs _+evalLisp (EEnv env _ _ _) (List (Symbol "defmacro" : List (Symbol var : params) : body)) = if paramsCheck params then do defineVar env var lispFalse makeNormalMacro env params body >>= setVar env var else errBadForm "defmacro" params-evalLisp env dcs _ (List (Symbol "defmacro" :+evalLisp (EEnv env _ _ _) (List (Symbol "defmacro" : DottedList (Symbol var : params) varargs : body)) = if paramsCheck (params ++ [varargs]) then do defineVar env var lispFalse makeVarargsMacro varargs env params body >>= setVar env var else errBadForm "defmacro" [DottedList params varargs] -evalLisp env dcs _ (List (Symbol "lambda" : List params : body)) =+evalLisp eenv (List (Symbol "lambda" : List params : body)) = if paramsCheck params- then makeNormalFunc env params body+ then makeNormalFunc (eeE eenv) params body else errBadForm "lambda" params-evalLisp env dcs _+evalLisp eenv (List (Symbol "lambda" : DottedList params varargs : body)) = if paramsCheck (params ++ [varargs])- then makeVarargsFunc varargs env params body+ then makeVarargsFunc varargs (eeE eenv) params body else errBadForm "lambda" [DottedList params varargs]-evalLisp env dcs _ (List (Symbol "lambda" : varargs@(Symbol _) : body)) =- makeVarargsFunc varargs env [] body+evalLisp eenv (List (Symbol "lambda" : varargs@(Symbol _) : body)) =+ makeVarargsFunc varargs (eeE eenv) [] body -evalLisp env dcs ql (List [Symbol "if", pred, tcase, fcase]) =- do result <- evalLisp env dcs ql pred+evalLisp eenv (List [Symbol "if", pr, tcase, fcase]) =+ do result <- evalLisp eenv pr case result of- Boolean False -> evalLisp env dcs ql fcase- _ -> evalLisp env dcs ql tcase-evalLisp env dcs ql (List [Symbol "if", pred, tcase]) =- do result <- evalLisp env dcs ql pred+ Boolean False -> evalLisp eenv fcase+ _ -> evalLisp eenv tcase+evalLisp eenv (List [Symbol "if", pr, tcase]) =+ do result <- evalLisp eenv pr case result of Boolean False -> return lispFalse- _ -> evalLisp env dcs ql tcase+ _ -> evalLisp eenv tcase -evalLisp env dcs ql (List (Symbol "and" : args)) = eva env args lispTrue+evalLisp eenv (List (Symbol "and" : args)) = eva (eeE eenv) args lispTrue where eva _ [] ret = return ret eva env (t:ts) _ =- do result <- evalLisp env dcs ql t+ do result <- evalLisp eenv t case result of Boolean False -> return lispFalse _ -> eva env ts result -evalLisp env dcs ql (List (Symbol "or" : args)) = evo env args lispFalse+evalLisp eenv (List (Symbol "or" : args)) = evo (eeE eenv) args lispFalse where evo _ [] ret = return ret evo env (t:ts) _ =- do result <- evalLisp env dcs ql t+ do result <- evalLisp eenv t case result of Boolean False -> evo env ts result _ -> return result -evalLisp _ _ _ (List [Symbol "cond"]) = return lispFalse-evalLisp env dcs ql (List (Symbol "cond" : args)) =- if foldl1 (&&) (map isList args) == False- then errTypeMismatch "cond" "cond-clauses" (String (show args))- else evc env args+evalLisp _ (List [Symbol "cond"]) = return lispFalse+evalLisp eenv (List (Symbol "cond" : args)) =+ if all isList args+ then evc (eeE eenv) args+ else errTypeMismatch "cond" "cond-clauses" (String (show args)) where evc _ [] = return lispFalse 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 <- mapML (evalLisp env dcs ql) args+ evc_clause _ (List (Symbol "else" : as)) =+ do ret <- mapML (evalLisp eenv) as return (True, ret)- evc_clause env (List (pred : args)) =- do tst <- evalLisp env dcs ql pred+ evc_clause env (List (pr : as)) =+ do tst <- evalLisp eenv pr case tst of Boolean False -> return (False, lispFalse)- _ -> do ret <- if isArrow args- then evcArrow env args tst- else mapML (evalLisp env dcs ql) args+ _ -> do ret <- if isArrow as+ then evcArrow env as tst+ else mapML (evalLisp eenv) as return (True, ret) evc_clause _ _ = return (False, lispFalse) isArrow [Symbol "=>", _] = True isArrow _ = False evcArrow env [Symbol "=>", proc] val =- evalLisp env dcs ql proc >>= (flip (apply dcs ql)) [val]+ let een = eeNewE eenv env+ in evalLisp een proc >>= flip (apply een) [val]+ evcArrow _ _ _ = progError "evalLisp/cond/evcArrow" -evalLisp env dcs ql (List (Symbol "let" : List params : body)) =+evalLisp eenv (List (Symbol "let" : List params : body)) = if letCheck True params- then do func <- makeNormalFunc env (map exn params) body- argVals <- mapM (evalLisp env dcs ql) (map exv params)- apply dcs ql func argVals+ then do func <- makeNormalFunc (eeE eenv) (map exn params) body+ mapM (evalLisp eenv . exv) params >>= apply eenv func else errBadForm "let" params- where exn (List [Symbol var, _]) = Symbol var- exv (List [Symbol _, val]) = val+ where exn (List [Symbol var, _]) = Symbol var+ exn _ = progError "evalLisp/let/exn1"+ exv (List [Symbol _, val]) = val+ exv _ = progError "evalLisp/let/exv1" -evalLisp env dcs ql+evalLisp eenv (List (Symbol "let" : Symbol lname : List params : body)) = if letCheck True params- then do envn <- liftIO (bindVars env [(lname, lispFalse)])+ then do envn <- liftIO (bindVars (eeE eenv) [(lname, lispFalse)]) func <- makeNormalFunc envn (map exn params) body setVar envn lname func- argVals <- mapM (evalLisp env dcs ql) (map exv params)- apply dcs ql func argVals+ mapM (evalLisp eenv . exv) params >>= apply eenv func else errBadForm "named-let" params- where exn (List [Symbol var, _]) = Symbol var- exv (List [Symbol _, val]) = val+ where exn (List [Symbol var, _]) = Symbol var+ exn _ = progError "evalLisp/let/exn2"+ exv (List [Symbol _, val]) = val+ exv _ = progError "evalLisp/let/exv2" -evalLisp env dcs ql (List (Symbol "let*" : List params : body)) =+evalLisp eenv (List (Symbol "let*" : List params : body)) = if letCheck False params- then dols params body env+ then dols params body (eeE eenv) else errBadForm "let*" params- where dols [] body env = mapML (evalLisp env dcs ql) body- dols (p:ps) body env =- do val <- evalLisp env dcs ql (exv p)- (liftIO (bindVars env [(exn p, val)])) >>= (dols ps body)+ where dols [] b env = mapML (evalLisp (eeNewE eenv env)) b+ dols (p:ps) b env =+ do val <- evalLisp (eeNewE eenv env) (exv p)+ liftIO (bindVars env [(exn p, val)]) >>= dols ps b exn (List [Symbol var, _]) = var+ exn _ = progError "evalLisp/let*/exn" exv (List [Symbol _, val]) = val+ exv _ = progError "evalLisp/let*/exv" -evalLisp env dcs ql (List (Symbol "letrec" : List params : body)) =+evalLisp eenv (List (Symbol "letrec" : List params : body)) = if letCheck True params- then dolr params body env+ then dolr params body (eeE eenv) else errBadForm "letrec" params- where dolr params body env =- do let varn = map exn params+ where dolr ps b env =+ do let varn = map exn ps envn <- liftIO (bindVars env varn)- varv <- mapM (evalLisp envn dcs ql) (map exv params)- mapM (doSet envn) (repl varn varv) >>- mapML (evalLisp envn dcs ql) body+ let een = eeNewE eenv envn+ varv <- mapM (evalLisp een . exv) ps+ mapM_ (doSet envn) (repl varn varv) >> mapML (evalLisp een) b exn (List [Symbol var, _]) = (var, lispFalse)+ exn _ = progError "evalLisp/letrec/exn" exv (List [Symbol _, val]) = val+ exv _ = progError "evalLisp/letrec/exv" repl [] [] = []- repl ((n, lispFalse):ns) (v:vs) = (n, v):(repl ns vs)+-- TODO: fix this! it's infelicitous... would prefer to not know+-- what lispFalse looks like on the inside+ repl ((n, Boolean False):ns) (v:vs) = (n, v) : repl ns vs+ repl _ _ = progError "evalLisp/letrec/repl" doSet env (n,v) = setVar env n v -evalLisp env dcs ql (List (Symbol "letrec*" : List params : body)) =+evalLisp eenv (List (Symbol "letrec*" : List params : body)) = if letCheck False params- then dolr params body env+ then dolr params body (eeE eenv) else errBadForm "letrec*" params- where dolr params body env =- do let varn = map exn params+ where dolr ps b env =+ do let varn = map exn ps envn <- liftIO (bindVars env varn)- mapM (evSet envn) params >>- mapML (evalLisp envn dcs ql) body+ mapM_ (evSet envn) ps >>+ mapML (evalLisp (eeNewE eenv envn)) b exn (List [Symbol var, _]) = (var, lispFalse)+ exn _ = progError "evalLisp/letrec*/exn" evSet env (List [Symbol var, val]) =- evalLisp env dcs ql val >>= setVar env var+ evalLisp (eeNewE eenv env) val >>= setVar env var+ evSet _ _ = progError "evalLisp/letrec*/evSet" -evalLisp _ _ _ (List [Symbol "case"]) = return lispFalse-evalLisp env dcs ql (List (Symbol "case" : key : args)) =- if (isNull args) || (foldl1 (&&) (map isLL args) == False)- then errTypeMismatch "case" "case-clauses" (String (show args))- else evalLisp env dcs ql key >>= evc env args- where isNull [] = True- isNull _ = False- isLL (List (List _ : _)) = True+evalLisp _ (List [Symbol "case"]) = return lispFalse+evalLisp eenv (List (Symbol "case" : k : as)) =+ if null as || not (all isLL as)+ then errTypeMismatch "case" "case-clauses" (String (show as))+ else evalLisp eenv k >>= evc (eeE eenv) as+ where isLL (List (List _ : _)) = True isLL (List (Symbol "else" : _)) = True isLL _ = False evc _ [] _ = return lispFalse- evc env (cl:cls) key = do (tst,val) <- evc_clause env cl key- if tst then return val else evc env cls key+ evc env (cl:cls) k1 = do (tst,val) <- evc_clause env cl k1+ if tst then return val else evc env cls k1 evc_clause env (List (Symbol "else" : args)) _ =- do ret <- mapML (evalLisp env dcs ql) args+ do ret <- mapML (evalLisp (eeNewE eenv env)) args return (True, ret)- evc_clause env (List (List vals : args)) key =- if valMatch key vals- then do ret <- mapML (evalLisp env dcs ql) args+ evc_clause env (List (List vals : args)) k1 =+ if valMatch k1 vals+ then do ret <- mapML (evalLisp (eeNewE eenv env)) args return (True, ret) else return (False, lispFalse) evc_clause _ _ _ = return (False, lispFalse)- valMatch key (v:vs) = if Library.eqv [key, v]- then True- else (valMatch key vs)+ valMatch k1 (v:vs) = Library.eqv [k1, v] || valMatch k1 vs valMatch _ [] = False -evalLisp env dcs ql+evalLisp eenv (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 (mapML (evalLisp env dcs ql) body)+ if all isList clauses+ then catchError (mapML (evalLisp eenv) body) (\err -> do let errval = unpackErr err- liftIO (bindVars env [(var, errval)]) >>=- evc err clauses)+ liftIO (bindVars (eeE eenv) [(var, errval)])+ >>= evc err clauses)+ else errTypeMismatch "guard" "error-clauses" (String (show clauses)) where 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 <- mapML (evalLisp env dcs ql) args+ do ret <- mapML (evalLisp (eeNewE eenv env)) args return (True, ret)- evc_clause env (List (pred : args)) =- do tst <- evalLisp env dcs ql pred+ evc_clause env (List (pr : args)) =+ do let een = eeNewE eenv env+ tst <- evalLisp een pr case tst of Boolean False -> return (False, lispFalse) _ -> do ret <- if isArrow args then evcArrow env args tst- else mapML (evalLisp env dcs ql) args+ else mapML (evalLisp een) args return (True, ret) evc_clause _ _ = return (False, lispFalse) isArrow [Symbol "=>", _] = True isArrow _ = False evcArrow env [Symbol "=>", proc] val =- evalLisp env dcs ql proc >>= (flip (apply dcs ql)) [val]+ let een = eeNewE eenv env+ in evalLisp een proc >>= flip (apply een) [val]+ evcArrow _ _ _ = progError "evalLisp/guard/evcArrow" -- 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@@ -670,14 +711,15 @@ -- 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+evalLisp eenv (List [Symbol "delay", val]) =+ do let env = eeE eenv+ dval <- getVar env delayCounter let count = getInt dval do setVar env delayCounter (IntNumber (count + 1))- return (Delay val env (" delay." ++ (show count)))+ return (Delay val env (" delay." ++ show count)) -evalLisp envc dcs ql (List [Symbol "force", val]) =- do vali <- evalLisp envc dcs ql val+evalLisp eenv (List [Symbol "force", val]) =+ do vali <- evalLisp eenv val if isDelay vali then do let (env, tag) = getTag vali alreadyDef <- liftIO (isBound env tag)@@ -688,84 +730,92 @@ where isDelay (Delay _ _ _) = True isDelay _ = False getTag (Delay _ env tag) = (env, tag)- forceEval (Delay obj env _) = evalLisp env dcs ql obj+ getTag _ = progError "evalLisp/getTag"+ forceEval (Delay obj env _) = evalLisp (eeNewE eenv env) obj+ forceEval _ = progError "evalLisp/forceEval" -evalLisp env dcs ql (List (Symbol "do" : List params : List test : body)) =+evalLisp eenv (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 dcs ql) (map exi params)- envn <- liftIO (bindVars env (zip names inits))+ inits <- mapM (evalLisp eenv . exi) params+ envn <- liftIO (bindVars (eeE eenv) (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+ exn _ = progError "evalLisp/do/exn"+ exi (List [Symbol _, ini]) = ini+ exi (List [Symbol _, ini, _]) = ini+ exi _ = progError "evalLisp/do/exi" exs (List [Symbol var, _]) = Symbol var exs (List [Symbol _, _, step]) = step+ exs _ = progError "evalLisp/do/exs" doSet env (n,v) = setVar env n v- doloop env names (test:rets) steps =- do tval <- evalLisp env dcs ql test+ doloop env names (tst:rets) steps =+ do let een = eeNewE eenv env+ tval <- evalLisp een tst if isTrue tval- then mapML (evalLisp env dcs ql) rets- else do mapM (evalLisp env dcs ql) body- svals <- mapM (evalLisp env dcs ql) steps- mapM (doSet env) (zip names svals)- doloop env names (test:rets) steps+ then mapML (evalLisp een) rets+ else do mapM_ (evalLisp een) body+ svals <- mapM (evalLisp een) steps+ mapM_ (doSet env) (zip names svals)+ doloop env names (tst:rets) steps+ doloop _ _ [] _ = progError "evalLisp/do/doloop" -- 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 "gensym"]) =+evalLisp (EEnv env _ _ _) (List [Symbol "gensym"]) = do sval <- getVar env symbolCounter let count = getInt sval do setVar env symbolCounter (IntNumber (count + 1))- return (Symbol (" symbol." ++ (show count)))+ return (Symbol (" symbol." ++ show count)) --- Delimited continuations -- two new special forms:--- (ext cont id expr ...) which is the translation of reset etc--- (int cont id flag1 flag2 expr ...) which is the translation of shift etc--- NOTE! 'int cont' and 'ext cont' are each a single symbol, with a--- space in the middle: this prevents the user from entering these directly--- ... well, not really, but it makes it enough harder that it has to be--- done intentionally: take an expression apart, rebuild it with a macro,--- and attempt to process that. If you do that, you deserve what you get.+-- Delimited continuations -- two new special forms: (reset expr ...)+-- and (shift id fname expr ...) which is the translation of shift --- TODO: we may need to add individual ids to the DelCont... this is part--- of delcont.scm, although I don't quite understand it+-- NOTE! 'shift ' is a single symbol, with a space at the end; this makes it+-- harder for the user to enter it directly (but not impossible: generate a+-- quoted expression like '(reset (shift f #t)), then take the result apart+-- to get the desired symbols... if you do this, you deserve what you get). -evalLisp env dcs ql (List ((Symbol "ext cont"):(Symbol id):args)) =- catchError (mapML (evalLisp env (args:dcs) ql) args)- (\val -> getVal val)+evalLisp eenv@(EEnv _ _ dcs _) (List (Symbol "reset" : as)) =+ catchError (mapML (evalLisp (eeNewDC eenv (as:dcs))) as) getVal where getVal (DelCont val) = return val getVal err = throwError err -evalLisp env [] ql a@(List ((Symbol "int cont"):- (Symbol id):(Boolean f1):(Boolean f2):(Symbol fn):args)) =+evalLisp (EEnv _ _ [] _)+ a@(List (Symbol "shift " : Symbol _ : Symbol _ : _)) = throwError (BadSpecial "naked internal delcont form" a) -- TODO: does the isCont test need to be made more discriminating? -- check if it could perhaps fail with nested or multiple calls to the -- continuation function --- TODO: look into why some of the reset0/prompt/prompt0 examples are failing+evalLisp eenv (List (Symbol "shift " : Symbol cid : Symbol fn : as)) =+ do let env = eeE eenv+ isCont = lookup cid (eePE eenv)+ case isCont of+ Just val -> return val+ Nothing -> do let cbody = [List (Symbol "reset" :+ head (eeDC eenv))]+ ebody = [List (Symbol "reset" : as)]+ func <- makeContFunc env [Symbol cid] cbody+ envn <- liftIO (bindVars env [(fn, func)])+ mapML (evalLisp (eeNewE eenv envn)) ebody+ >>= throwError . DelCont -evalLisp env dcs ql (List ((Symbol "int cont"):- (Symbol id):(Boolean f1):(Boolean f2):(Symbol fn):args)) =- do isCont <- liftIO (isBound env id)+{- if isCont- then (getVar env id) >>= return- else do cbody <- wrapit f1 (head dcs)- func <- makeNormalFunc env [Symbol id] cbody+ then (getVar env cid) >>= return+ else do let cbody = [List ([Symbol "reset"] ++ (head (eeDC eenv)))]+ ebody = [List ([Symbol "reset"] ++ as)]+ func <- makeContFunc env [Symbol cid] cbody envn <- liftIO (bindVars env [(fn, func)])- ebody <- wrapit f2 args- mapML (evalLisp envn dcs ql) ebody >>= throwError . DelCont- where wrapit flag exs =- if flag- then do wrap <- evalPP env (List ((Symbol "RESET"):[lispFalse]))- return [List ((take 2 (getList wrap)) ++ exs)]- else return exs+ mapML (evalLisp (eeNewE eenv envn)) ebody+ >>= throwError . DelCont+-} -- 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@@ -780,75 +830,75 @@ -- expression which evaluates to the symbol to trace, because we want -- to have a name: var is what gets used. Consider relaxing this? -evalLisp env dcs ql (List [Symbol "trace", Symbol var, sw]) =+evalLisp eenv (List [Symbol "trace", Symbol var, sw]) = if isSpecialForm (Symbol var) then throwError (Default "can't trace special forms")- else do val <- evalLisp env dcs ql (Symbol var)- swval <- evalLisp env dcs ql sw+ else do val <- evalLisp eenv (Symbol var)+ swval <- evalLisp eenv sw+ let env = eeE eenv if isPr val then throwError (Default "can't trace primitives")- else if (isF val)+ else if isF val -- TODO: this can be cleaned up a bit more... doit!- then if (isTrue swval)- then (remark ("trace " ++ var ++ " on")) >>+ then if isTrue swval+ then remark ("trace " ++ var ++ " on") >> setVar env var (trOn var val) >> return lispTrue- else (remark ("trace " ++ var ++ " off")) >>+ else remark ("trace " ++ var ++ " off") >> setVar env var (trOff val) >> return lispFalse- else errBadForm "trace" ((Symbol var):[sw])+ else errBadForm "trace" (Symbol var : [sw]) where isPr (Prim _) = True isPr (IOPrim _) = True isPr _ = False- isF (Func _ _ _ _ _ _) = True+ isF (Func _ _ _ _ _ _ _) = True isF _ = False- trOn name (Func params varargs body closure _ mac) =- (Func params varargs body closure (Just name) mac)- trOn _ _ = progError- trOff (Func params varargs body closure _ mac) =- (Func params varargs body closure Nothing mac)- trOff _ = progError+ trOn name (Func params varargs body closure _ mac cont) =+ Func params varargs body closure (Just name) mac cont+ trOn _ _ = progError "evalLisp/trace/trOn"+ trOff (Func params varargs body closure _ mac cont) =+ Func params varargs body closure Nothing mac cont+ trOff _ = progError "evalLisp/trace/trOff" -- 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 dcs ql (List [Symbol "dump-bindings", val]) =- do vali <- evalLisp env dcs ql val+evalLisp eenv (List [Symbol "dump-bindings"]) = dumpEnv (eeE eenv) stderr []+evalLisp eenv (List [Symbol "dump-bindings", val]) =+ do vali <- evalLisp eenv val if isPort vali- then dumpEnv env (getPort vali)+ then dumpEnv (eeE eenv) (getPort vali) [] else errBadForm "dump-bindings" [val] where isPort (Port _) = True isPort _ = False getPort (Port p) = p- getPort _ = progError+ getPort _ = progError "evalLisp/dump-bindings" --- The generic (function : args) stuff; also macro expansion stuff+-- The generic (function : as) stuff; also macro expansion stuff -- For macro expansion, we evaluate once to get syntax back from the -- macro, that's the "evalLisp env dcs ql function", but then we change -- the environment to evaluate that syntax in the caller's environment. -evalLisp env dcs ql (List (function : args)) =+evalLisp eenv (List (function : as)) = if isSpecialForm function then throwError (BadSpecial "bad syntax for special form" function)- else do func <- evalLisp env dcs ql function+ else do func <- evalLisp eenv function if isM func- then apply dcs ql (chEnv func env) args >>=- prtTrace (isT func) >>=- evalPP env >>=- evalLisp env dcs ql- else mapM (evalLisp env dcs ql) args >>= apply dcs ql func- where isM (Func _ _ _ _ _ mac) = mac+ then apply eenv (chEnv func (eeE eenv)) as >>=+ prtTrace (isT func) >>= evalPP eenv >>= evalLisp eenv+ else mapM (evalLisp eenv) as >>= apply eenv func+ where isM (Func _ _ _ _ _ mac _) = mac isM _ = False- isT (Func _ _ _ _ (Just _) _) = True+ isT (Func _ _ _ _ (Just _) _ _) = True isT _ = False- chEnv (Func pars vars bod envo name mac) envn =- Func pars vars bod envn name mac+ chEnv (Func pars vars bod _ name mac cont) envn =+ Func pars vars bod envn name mac cont+ chEnv _ _ = progError "evalLisp/generic-function" prtTrace trace vals = if trace- then remark (" -> " ++ (show vals)) >> return vals+ then remark (" -> " ++ show vals) >> return vals else return vals -evalLisp _ _ _ badForm =+evalLisp _ badForm = throwError (BadSpecial "Unrecognized special form" badForm)
Library.hs view
@@ -18,8 +18,10 @@ 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.39 2009-08-06 05:05:15 uwe Exp $ -}+$Id: library.hs,v 1.43 2010-01-18 00:08:49 uwe Exp $ -} +{-# LANGUAGE FlexibleContexts #-}+ module Library (primitiveBindings, delayCounter, symbolCounter, contCounter, loadFile, eqv) where@@ -47,9 +49,14 @@ import Environment import WriteNumber -errNumArgs name want got = throwError (NumArgs name want got)-errTypeMismatch name want got = throwError (TypeMismatch name want got)+errNumArgs :: MonadError LispError m =>+ String -> Integer -> [LispVal] -> m a+errNumArgs name want = throwError . NumArgs name want +errTypeMismatch :: MonadError LispError m =>+ String -> String -> LispVal -> m a+errTypeMismatch name want = throwError . TypeMismatch name want+ genericBadArg :: [LispVal] -> String -> String -> Int -> ThrowsError LispVal genericBadArg badArgList func want num =@@ -61,7 +68,7 @@ -> IOThrowsError LispVal genericIOBadArg badArgList func want num = if length badArgList == num- then errTypeMismatch func want (badArgList !! 0)+ then errTypeMismatch func want (head badArgList) else errNumArgs func (toInteger num) badArgList -- A bunch of library functions that don't do IO:@@ -83,7 +90,7 @@ isInteger :: [LispVal] -> ThrowsError LispVal isInteger [IntNumber _] = return lispTrue-isInteger [RatNumber n] = return (Boolean ((denominator n) == 1))+isInteger [RatNumber n] = return (Boolean (denominator n == 1)) isInteger _ = return lispFalse isRational :: [LispVal] -> ThrowsError LispVal@@ -123,7 +130,7 @@ isProcedure :: [LispVal] -> ThrowsError LispVal isProcedure [Prim _] = return lispTrue isProcedure [IOPrim _] = return lispTrue-isProcedure [Func _ _ _ _ _ _] = return lispTrue+isProcedure [Func _ _ _ _ _ _ _] = return lispTrue isProcedure _ = return lispFalse isVector :: [LispVal] -> ThrowsError LispVal@@ -138,7 +145,7 @@ isZero [IntNumber n] = if n == 0 then return lispTrue else return lispFalse isZero [RatNumber n] =- if (n == 0) then return lispTrue else return lispFalse+ if n == 0 then return lispTrue else return lispFalse isZero [FltNumber n] = if n == 0 then return lispTrue else return lispFalse isZero _ = return lispFalse@@ -174,21 +181,21 @@ lispIsNaN :: [LispVal] -> ThrowsError LispVal lispIsNaN [RatNumber n] =- return (Boolean (((numerator n) == 0) && ((denominator n) == 0)))+ return (Boolean (numerator n == 0 && denominator n == 0)) lispIsNaN [FltNumber n] = return (Boolean (isNaN n)) lispIsNaN _ = return lispFalse lispIsInf :: [LispVal] -> ThrowsError LispVal lispIsInf [RatNumber n] = - return (Boolean (((numerator n) /= 0) && ((denominator n) == 0)))+ return (Boolean (numerator n /= 0 && denominator n == 0)) lispIsInf [FltNumber n] = return (Boolean (isInfinite n)) lispIsInf _ = return lispFalse lispIsFinite :: [LispVal] -> ThrowsError LispVal lispIsFinite [IntNumber _] = return lispTrue-lispIsFinite [RatNumber n] = return (Boolean ((denominator n) /= 0))+lispIsFinite [RatNumber n] = return (Boolean (denominator n /= 0)) lispIsFinite [FltNumber n] =- return (Boolean (not ((isInfinite n) && (isNaN n))))+ return (Boolean (not (isInfinite n && isNaN n))) lispIsFinite _ = return lispFalse lispIsEven :: [LispVal] -> ThrowsError LispVal@@ -203,6 +210,7 @@ lispId :: [LispVal] -> ThrowsError LispVal lispId [val@(_)] = return val+lispId _ = progError "library/Id" lispNot :: [LispVal] -> ThrowsError LispVal lispNot [Boolean False] = return lispTrue@@ -215,7 +223,7 @@ unpackIntNum :: LispVal -> ThrowsError Integer unpackIntNum (IntNumber n) = return n unpackIntNum (RatNumber n) =- if (denominator n) /= 0+ if denominator n /= 0 then return (truncate n) else errTypeMismatch "<unpackIntNum>" "number" (RatNumber n) unpackIntNum (FltNumber n) = return (truncate n)@@ -263,27 +271,29 @@ scanRatNaN :: [LispVal] -> Bool scanRatNaN [] = False scanRatNaN (IntNumber _:vs) = scanRatNaN vs-scanRatNaN (RatNumber v:vs) = if v == myRatNaN then True else scanRatNaN vs+scanRatNaN (RatNumber v:vs) = (v == myRatNaN) || scanRatNaN vs+scanRatNaN _ = progError "library/scanRatNaN" 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+scanFltNaN (RatNumber v:vs) = (v == myRatNaN) || scanFltNaN vs+scanFltNaN (FltNumber v:vs) = isNaN v || scanFltNaN vs+scanFltNaN _ = progError "library/scanFltNaN" getType :: [LispVal] -> Int getType p = foldl1 max (map g p)- where g (IntNumber _) = isIntType- g (RatNumber _) = isRatType- g (FltNumber _) = isFltType- g _ = isOther+ where g (IntNumber _) = isIntType+ g (RatNumber _) = isRatType+ g (FltNumber _) = isFltType+ g _ = isOther isNumType :: Int -> Bool-isNumType n = (n == isIntType || n == isRatType || n == isFltType)+isNumType n = n == isIntType || n == isRatType || n == isFltType intOrRat :: Rational -> LispVal-intOrRat n | (denominator n) == 1 = (IntNumber (numerator n))- | otherwise = (RatNumber n)+intOrRat n | denominator n == 1 = IntNumber (numerator n)+ | otherwise = RatNumber n numericBinop :: String -> (Integer -> Integer -> Integer) -> (Rational -> Rational -> Rational) ->@@ -292,7 +302,7 @@ numericBinop name intOp ratOp dblOp av = do let mytype = getType av if length av < 2- then errNumArgs name 2 ((String (show (length av))) : av)+ then errNumArgs name 2 (String (show (length av)) : av) else if mytype == isIntType then mapM unpackIntNum av >>= return . IntNumber . foldl1 intOp@@ -322,6 +332,8 @@ -- wrappers around rational comparison operators so that -- we can deal properly with infinities and NaNs +myRatEQ, myRatNE, myRatLT, myRatLE, myRatGT, myRatGE ::+ Rational -> Rational -> Bool myRatEQ n1 n2 | n1 == myRatNaN || n2 == myRatNaN = False | otherwise = n1 == n2 @@ -357,19 +369,19 @@ if length av < 2 then errNumArgs name 2 av else if mytype == isIntType- then do ll <- unpackIntNum (av !! 0)+ then do ll <- unpackIntNum (head av) rr <- unpackIntNum (av !! 1) return (Boolean (intOp ll rr)) else if mytype == isRatType then if scanRatNaN av then return (Boolean nanval)- else do ll <- unpackRatNum (av !! 0)+ else do ll <- unpackRatNum (head av) rr <- unpackRatNum (av !! 1) return (Boolean (ratOp ll rr)) else if mytype == isFltType then if scanFltNaN av then return (Boolean nanval)- else do ll <- unpackFltNum (av !! 0)+ else do ll <- unpackFltNum (head av) rr <- unpackFltNum (av !! 1) return (Boolean (dblOp ll rr)) else errTypeMismatch name "number" (List av)@@ -382,7 +394,7 @@ else if isNumType mytype then if scanFltNaN av then return libFltNaN- else unpackFltNum (av !! 0) >>=+ else unpackFltNum (head av) >>= return . FltNumber . fun else errTypeMismatch name "number" (List av) @@ -419,30 +431,30 @@ -- infinities were necessarily inexact. myrecip :: Rational -> Rational-myrecip n | n == myRatNaN = myRatNaN- | (n == myRatPInf || n == myRatNInf) = 0- | n == 0 = myRatPInf- | otherwise = (recip n)+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+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+ | sg n1 == sg n2 = myRatPInf | otherwise = myRatNInf- where sg n = if n > 0 then 1 else -1+ where sg n = if n > 0 then 1::Int else -1::Int myadd :: Rational -> Rational -> Rational-myadd n1 n2 | ((denominator n1 /= 0) &&- (denominator n2 /= 0)) = n1 + n2+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+ | denominator n1 /= 0 = n2 | otherwise = n1 mymin :: Rational -> Rational -> Rational@@ -458,18 +470,19 @@ else max n1 n2 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+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, mulOp :: [LispVal] -> ThrowsError LispVal addOp = numericBinop "+" (+) myadd (+) mulOp = numericBinop "*" (*) mymul (*) @@ -482,15 +495,15 @@ lispPlus (v:vs) = addOp (v:vs) lispMinus :: [LispVal] -> ThrowsError LispVal+lispMinus [] = return (IntNumber 0) 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)+ do aux <- addOp (IntNumber 0 : as) rec <- lispMinus [aux]- res <- addOp (a:[rec])- return res+ addOp (a:[rec]) lispMul :: [LispVal] -> ThrowsError LispVal lispMul [] = return (IntNumber 1)@@ -501,19 +514,19 @@ lispMul (v:vs) = mulOp (v:vs) lispDiv :: [LispVal] -> ThrowsError LispVal+lispDiv [] = return (IntNumber 1) lispDiv [IntNumber n] = return (RatNumber (myrecip (fromInteger n))) lispDiv [RatNumber n] = let nr = myrecip n- in if (denominator nr) == 1+ 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)+ do aux <- mulOp (IntNumber 1 : as) rec <- lispDiv [aux]- res <- mulOp (a:[rec])- return res+ mulOp (a:[rec]) lispMin :: [LispVal] -> ThrowsError LispVal lispMin [] = errNumArgs "min" 1 []@@ -541,8 +554,8 @@ | x == 0 = if y > 0 then IntNumber 0 else libRatPInf- | (abs x) < 1 && y > 0 && isInfinite y = IntNumber 0- | (abs x) > 1 && y < 0 && isInfinite y = IntNumber 0+ | abs x < 1 && y > 0 && isInfinite y = IntNumber 0+ | abs x > 1 && y < 0 && isInfinite y = IntNumber 0 | x == -1 && isInfinite y = libFltNaN | x < -1 && y > 0 && isInfinite y = libFltNaN | x > -1 && x < 0 && y < 0 && isInfinite y = libFltNaN@@ -551,40 +564,40 @@ 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+ | x == -1 && abs y == myRatPInf = libRatNaN+ | x == myRatNInf && y > 0 && denominator y > 1 = libRatNaN | x == myRatPInf && y == 0 = libRatNaN- | (abs x) == myRatPInf && y > 0 = libRatPInf+ | 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+ | 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+ 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)+ 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+ then errNumArgs "**" 2 av else do let mytype = getType av if isNumType mytype- then if (mytype == isIntType || mytype == isRatType)+ then if mytype == isIntType || mytype == isRatType then if scanRatNaN av then return libRatNaN- else do b <- unpackRatNum (av !! 0)+ else do b <- unpackRatNum (head av) e <- unpackRatNum (av !! 1) return (ratpow b e) else if scanFltNaN av then return libFltNaN- else do b <- unpackFltNum (av !! 0)+ else do b <- unpackFltNum (head av) e <- unpackFltNum (av !! 1) return (fltpow b e) else errTypeMismatch "expt" "number" (List av)@@ -594,11 +607,16 @@ boolBinop unpacker name op args = if length args /= 2 then errNumArgs name 2 args- else do ll <- unpacker (args !! 0)+ else do ll <- unpacker (head args) rr <- unpacker (args !! 1) return (Boolean (ll `op` rr)) +strBoolBinop :: String -> (String -> String -> Bool) -> [LispVal] ->+ ThrowsError LispVal strBoolBinop = boolBinop unpackStr++charBoolBinop :: String -> (Char -> Char -> Bool) -> [LispVal] ->+ ThrowsError LispVal charBoolBinop = boolBinop unpackChar car :: [LispVal] -> ThrowsError LispVal@@ -614,30 +632,30 @@ 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 [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 [(Boolean v1), (Boolean 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 [(Boolean v1), (Boolean 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 ++ [t1]), List (l2 ++ [t2])] eqv [(List l1), (List l2)] =- ((length l1 == length l2) && (and (map eqvPair (zip l1 l2))))+ length l1 == length l2 && all 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))))))+ l1 == l2 && all eqvPair (zip (getval (DIM.toAscList v1))+ (getval (DIM.toAscList v2))) where eqvPair (x1,x2) = eqv [x1,x2] getval [] = []- getval ((_,v):vs) = v:(getval vs)+ getval ((_,v):vs) = v : getval vs eqv _ = False eqvFunc :: [LispVal] -> ThrowsError LispVal@@ -655,7 +673,7 @@ char2str :: [LispVal] -> ThrowsError LispVal char2str [] = return (String "") char2str [List chars] = char2str chars-char2str chars = mapM unpackChar chars >>= return . String . (foldr (:) [])+char2str chars = mapM unpackChar chars >>= return . String . foldr (:) [] str2char :: [LispVal] -> ThrowsError LispVal str2char [] = return (List [])@@ -671,8 +689,9 @@ str2symb [String []] = genericBadArg [String ""] "string->symbol" "string" 1 str2symb [String s] = return (Symbol (sanitize s)) where sanitize (c:cs) = schar isAlpha c : map (schar isAlphaNum) cs- schar pred c =- if (pred c) || (c `elem` specialSymbolChars) then c else '_'+ sanitize [] = "_"+ schar pr c =+ if pr c || elem c specialSymbolChars then c else '_' str2symb badArgList = genericBadArg badArgList "string->symbol" "string" 1 readNum :: [LispVal] -> ThrowsError LispVal@@ -695,7 +714,7 @@ lispFloor :: [LispVal] -> ThrowsError LispVal lispFloor [IntNumber c] = return (IntNumber c) lispFloor [RatNumber c] =- if (denominator c) /= 0+ if denominator c /= 0 then return (IntNumber (floor c)) else return (RatNumber c) lispFloor [FltNumber c] = return (IntNumber (floor c))@@ -704,7 +723,7 @@ lispTruncate :: [LispVal] -> ThrowsError LispVal lispTruncate [IntNumber c] = return (IntNumber c) lispTruncate [RatNumber c] =- if (denominator c) /= 0+ if denominator c /= 0 then return (IntNumber (truncate c)) else return (RatNumber c) lispTruncate [FltNumber c] = return (IntNumber (truncate c))@@ -719,8 +738,8 @@ roundToAP :: RealFrac a => a -> Integer -> Integer -> a roundToAP n b d =- let bd = (fromInteger (b^d))- in (fromInteger (round (n * bd)))/bd+ 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@@ -728,12 +747,12 @@ roundToAN :: RealFrac a => a -> Integer -> Integer -> Integer roundToAN n b d = let bd = b^d- in bd*(round (n/(fromInteger bd)))+ in bd * round (n / fromInteger bd) lispRound :: [LispVal] -> ThrowsError LispVal lispRound [IntNumber c] = return (IntNumber c) lispRound [RatNumber c] =- if (denominator c) /= 0+ if denominator c /= 0 then return (IntNumber (round c)) else return (RatNumber c) lispRound [FltNumber c] = return (IntNumber (round c))@@ -742,27 +761,27 @@ 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)))+ else throwError (Default ("bad base arg to round: " ++ show b)) lispRound [RatNumber c, IntNumber b, IntNumber d] =- if (denominator c) /= 0+ 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 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)))+ 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+ if denominator c /= 0 then return (IntNumber (ceiling c)) else return (RatNumber c) lispCeiling [FltNumber c] = return (IntNumber (ceiling c))@@ -788,9 +807,10 @@ _ -> errNumArgs "atan" 2 av else errTypeMismatch "atan" "number" (List av) where at2 (y:x:[]) = atan2 y x+ at2 _ = progError "library/ATan2" lispListFromArgs :: [LispVal] -> ThrowsError LispVal-lispListFromArgs vals = return (List vals)+lispListFromArgs = return . List lispReverse :: [LispVal] -> ThrowsError LispVal lispReverse [List lst] = return (List (reverse lst))@@ -831,13 +851,11 @@ 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 [IntNumber n]+ | n == 0 = return (IntNumber 1)+ | n > 0 = return (IntNumber (product [1 .. n]))+ | otherwise = genericBadArg [IntNumber n] "factorial"+ "non-negative integer" 1 lispFactorial badArgList = genericBadArg badArgList "factorial" "integer" 1 -- Vector primitives@@ -849,20 +867,20 @@ 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))+ 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)+ 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)+ addkey n (v:vs) = (n, v) : addkey (n+1) vs lispListToVec badArgList = genericBadArg badArgList "list->vector" "list" 1 @@ -870,7 +888,7 @@ lispVecToList [Vector _ vec] = return (List (getval (DIM.toAscList vec))) where getval [] = []- getval ((_,v):vs) = v:(getval vs)+ getval ((_,v):vs) = v : getval vs lispVecToList badArgList = genericBadArg badArgList "vector->list" "vector" 1 @@ -880,7 +898,7 @@ lispVecRef :: [LispVal] -> ThrowsError LispVal lispVecRef [Vector len vec, IntNumber n] =- if (n >= 0 && n < len)+ if n >= 0 && n < len then return (DIM.findWithDefault lispFalse (fromInteger n) vec) else throwError (VectorBounds len (IntNumber n)) lispVecRef badArgList =@@ -895,7 +913,7 @@ 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 [Func pars var body _ _ _ _] = return (getfn pars var body) proc2data [Delay obj _ _] = return obj proc2data [Prim _] = throwError (Default "procedure->data can't handle builtin functions")@@ -950,7 +968,7 @@ bitsGet :: [LispVal] -> ThrowsError LispVal bitsGet [IntNumber n1, IntNumber n2] =- return (IntNumber (n1 .&. (bit (fromInteger n2))))+ return (IntNumber (n1 .&. bit (fromInteger n2))) bitsGet badArgList = genericBadArg badArgList "bits-get" "integer" 2 bitsIsSet :: [LispVal] -> ThrowsError LispVal@@ -1094,6 +1112,8 @@ -- 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 :: (MonadIO m, MonadError LispError m) =>+ IO a -> (a -> LispVal) -> (IOError -> Bool) -> m LispVal doIOAction action ctor epred = do ret <- liftIO (try action) case ret of@@ -1108,10 +1128,15 @@ -- 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 :: t -> LispVal dropToBool _ = lispTrue++allErrs :: t -> Bool allErrs _ = True-noEOF err = not (isEOFError err) +noEOF :: IOError -> Bool+noEOF = not . isEOFError+ makePort :: IOMode -> [LispVal] -> IOThrowsError LispVal makePort mode [String filename] = doIOAction (openFile filename mode) Port allErrs@@ -1150,6 +1175,7 @@ case str of Boolean False -> throwError (Default "operation failed") String val -> liftThrows (readExprList val)+ _ -> progError "library/loadFile" readAll :: [LispVal] -> IOThrowsError LispVal readAll [String filename] = liftM List (loadFile filename)@@ -1162,7 +1188,7 @@ 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)+lispPutStr (s:ss) = lispPutStr (Port stdout : s : ss) flushPort :: [LispVal] -> IOThrowsError LispVal flushPort [] = flushPort [Port stdout]@@ -1242,27 +1268,23 @@ lispGetCurrentDir :: [LispVal] -> IOThrowsError LispVal lispGetCurrentDir [] =- doIOAction (getCurrentDirectory) String allErrs+ 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)+ doIOAction (getDirectoryContents dirname) (List . map String) allErrs lispGetDirContents badArgList = genericIOBadArg badArgList "read-directory" "string" 1 lispGetEnv :: [LispVal] -> IOThrowsError LispVal lispGetEnv [] =- doIOAction (getEnvironment) loSS allErrs- where loSS arr = List (toSS arr)- toSS [] = []+ doIOAction getEnvironment (List . toSS) allErrs+ where toSS [] = [] toSS ((key,val):strs) =- (DottedList [String key] (String val)):(toSS strs)+ DottedList [String key] (String val) : toSS strs lispGetEnv [String key] = doIOAction (getEnvDefault key "") String allErrs lispGetEnv badArgList =@@ -1281,28 +1303,28 @@ lispEpochTime :: [LispVal] -> IOThrowsError LispVal-lispEpochTime [] = doIOAction (getClockTime) getET allErrs+lispEpochTime [] = doIOAction getClockTime getET allErrs where getET (TOD sec psec) =- FltNumber ((fromInteger sec) + 1.0e-12*(fromInteger 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 [] = doIOAction getClockTime toS allErrs+ where toS = String . show lispLocalTime [IntNumber n] = doIOAction (toCalendarTime (TOD n 0)) toS allErrs- where toS val = String (calendarTimeToString val)+ where toS = String . calendarTimeToString lispLocalTime [RatNumber n] = doIOAction (toCalendarTime (TOD (round n) 0)) toS allErrs- where toS val = String (calendarTimeToString val)+ where toS = String . calendarTimeToString lispLocalTime [FltNumber n] = doIOAction (toCalendarTime (TOD (round n) 0)) toS allErrs- where toS val = String (calendarTimeToString val)+ where toS = String . calendarTimeToString lispLocalTime badArgList = genericIOBadArg badArgList "localtime" "nothing" 0 lispUTCTime :: [LispVal] -> IOThrowsError LispVal-lispUTCTime [] = doIOAction (getClockTime) toS allErrs- where toS val = String (calendarTimeToString (toUTCTime val))+lispUTCTime [] = doIOAction getClockTime toS allErrs+ where toS = String . calendarTimeToString . toUTCTime lispUTCTime [IntNumber n] = return (String (calendarTimeToString (toUTCTime (TOD n 0)))) lispUTCTime [RatNumber n] =@@ -1313,8 +1335,8 @@ lispGetCPUTime :: [LispVal] -> IOThrowsError LispVal lispGetCPUTime [] =- doIOAction (getCPUTime) toS allErrs- where toS val = FltNumber ((fromInteger val)/1.0e12)+ doIOAction getCPUTime toS allErrs+ where toS val = FltNumber (1.0e-12 * fromInteger val) lispGetCPUTime badArgList = genericIOBadArg badArgList "cputime" "nothing" 0 @@ -1331,7 +1353,7 @@ getET (accessTime stat), getET (modificationTime stat), getET (statusChangeTime stat)]- where getET t = FltNumber (realToFrac t)+ where getET = FltNumber . realToFrac lispGetFileStatus :: [LispVal] -> IOThrowsError LispVal lispGetFileStatus [String filename] =@@ -1404,7 +1426,7 @@ lispRandExp :: [LispVal] -> IOThrowsError LispVal lispRandExp [FltNumber m] = if m > 0- then getrand >>= return . FltNumber . (sc m) . negate . log+ then getrand >>= return . FltNumber . (/ m) . negate . log else genericIOBadArg [FltNumber m] "random-exponential" "positive rate" 1 where getrand = do val <- lispRandUni []@@ -1412,7 +1434,7 @@ then getrand else return (getnum val) getnum (FltNumber n) = n- sc s v = v/s+ getnum _ = progError "library/RandExp/getnum" lispRandExp [] = lispRandExp [FltNumber 1.0] lispRandExp [IntNumber m] = lispRandExp [FltNumber (fromInteger m)] lispRandExp [RatNumber m] = lispRandExp [FltNumber (fromRational m)]@@ -1424,19 +1446,20 @@ if s > 0 then do x1 <- getrand x2 <- getrand- let a = s*sqrt (-2.0*(log x1))+ let a = s*sqrt (-2.0 * log x1) b = 2.0*pi*x2- y1 = m + a*(cos b)- y2 = m + a*(sin b)+ 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)))+ ++ " got " ++ show s)) where getrand = do val <- lispRandUni [] if getnum val == 0 then getrand else return (getnum val) getnum (FltNumber n) = n+ getnum _ = progError "library/RandNorm/getnum" lispRandNorm [] = lispRandNorm [FltNumber 0.0, FltNumber 1.0] lispRandNorm [IntNumber m, IntNumber s] = lispRandNorm [FltNumber (fromInteger m), FltNumber (fromInteger s)]@@ -1465,17 +1488,19 @@ then do val <- doit (exp (-lambda)) (-1) (1 :: Double) return (IntNumber val) else throwError (Default ("random-poisson needs a positive lambda,"- ++ " got " ++ (show lambda)))+ ++ " got " ++ show lambda)) where doit l k p = do r <- lispRandUni []- let pp = p*(getnum r)+ let pp = p * getnum r kp = k + 1 if pp < l then return kp else doit l kp pp getnum (FltNumber n) = n+ getnum _ = progError "library/RandPoisson/getnum" lispRandPoisson [IntNumber m] = lispRandPoisson [FltNumber (fromInteger m)] lispRandPoisson [RatNumber m] = lispRandPoisson [FltNumber (fromRational m)]+lispRandPoisson _ = progError "library/RandPoisson" lispSeedRandom :: [LispVal] -> IOThrowsError LispVal lispSeedRandom [IntNumber n] =@@ -1557,6 +1582,7 @@ Left err -> throwError (Default (show err)) Right val -> return (Port (val2 val)) where val2 (_, Just hout, _, _) = hout+ val2 _ = progError "library/ReadCmd" lispReadCmd badArgList = genericIOBadArg badArgList "run-read-command" "command+dir" 2 @@ -1570,6 +1596,7 @@ Left err -> throwError (Default (show err)) Right val -> return (Port (val1 val)) where val1 (Just hin, _, _, _) = hin+ val1 _ = progError "library/WriteCmd" lispWriteCmd badArgList = genericIOBadArg badArgList "run-write-command" "command+dir" 2 @@ -1632,10 +1659,10 @@ -- A couple of predefined data values ioPorts :: [(String, LispVal)]-ioPorts = [("stdin", (Port stdin)),- ("stdout", (Port stdout)),- ("stderr", (Port stderr)),- ("pi", (FltNumber pi))]+ioPorts = [("stdin", Port stdin),+ ("stdout", Port stdout),+ ("stderr", Port stderr),+ ("pi", FltNumber pi)] -- And finally some stuff for internal work @@ -1662,6 +1689,6 @@ primitiveBindings :: IO Env primitiveBindings = newIORef [] >>=- (flip bindVars (internals ++ map (mkf IOPrim) ioPrimitives ++- map (mkf Prim) primitives ++ ioPorts))+ flip bindVars (internals ++ map (mkf IOPrim) ioPrimitives +++ map (mkf Prim) primitives ++ ioPorts) where mkf constructor (var, func) = (var, constructor func)
LispData.hs view
@@ -18,7 +18,7 @@ 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.17 2009-08-06 05:05:15 uwe Exp $ -}+$Id: lispdata.hs,v 1.21 2010-01-05 05:23:34 uwe Exp $ -} module LispData (LispVal(Symbol, Boolean, Char, Delay, DottedList, IntNumber,@@ -27,9 +27,11 @@ LispError(NumArgs, TypeMismatch, Parser, BadSpecial, NotFunction, UnboundVar, Default, OutOfRange, VectorBounds, UserException, DelCont),- ThrowsError, Env, IOThrowsError, liftThrows,+ ThrowsError, Env, PureEnv, IOThrowsError, liftThrows, myRatPInf, myRatNInf, myRatNaN, myFltPInf, myFltNInf, myFltNaN,- lispTrue, lispFalse) where+ lispTrue, lispFalse,+ EEnv(EEnv), eeE, eePE, eeDC, eeQL, eeNewE, eeNewPE, eeNewDC,+ eeQLIncr, eeQLDecr, progError) where import Prelude import IO hiding (try) import Data.Char@@ -54,14 +56,18 @@ -- floating-point infinities and NaN myFltPInf, myFltNInf, myFltNaN :: Double-myFltPInf = (1.0e99 ** 1.0e99) -- probably big enough...-myFltNInf = (-myFltPInf)+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 pure env: just strings and LispVals++type PureEnv = [(String, LispVal)]+ -- A lisp value: these are the stuff which normally gets processed data LispVal = Symbol String@@ -79,7 +85,8 @@ body :: [LispVal], closure :: Env, name :: (Maybe String),- macro :: Bool}+ macro :: Bool,+ cont :: Bool} | Delay {obj :: LispVal, closure :: Env, tag :: String}@@ -96,33 +103,33 @@ showVal (Boolean False) = "#f" showVal (IntNumber num) = show num showVal (RatNumber num) =- (show (numerator num)) ++ "/" ++ (show (denominator 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) ++ ")"+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 (Char ch) | ch == chr 0 = "#\\nul"+ | ch == chr 7 = "#\\alarm"+ | ch == chr 8 = "#\\backspace"+ | ch == '\t' = "#\\tab"+ | ch == '\n' = "#\\linefeed"+ | ch == chr 11 = "#\\vtab"+ | ch == chr 12 = "#\\page"+ | ch == '\r' = "#\\return"+ | ch == chr 27 = "#\\esc"+ | ch == ' ' = "#\\space"+ | ch == chr 127 = "#\\delete"+ | isControl ch = "#\\^" ++ [chr (ord ch + ord 'A' - 1)]+ | isPrint ch = "#\\" ++ [ch]+ | otherwise = [ch] showVal (Prim _) = "<primitive>"-showVal (Func {params = args, vararg = varargs, body = bd,- closure = _, name = nm, macro = ismac}) =+showVal (Func {params = args, vararg = varargs, body = _,+ closure = _, name = nm, macro = ismac, cont = _}) = let lopen = if ismac then "<macro" else "(lambda" lclose = if ismac then ">" else ")"- inner = lopen ++ " (" ++ (unwords args) +++ inner = lopen ++ " (" ++ unwords args ++ (case varargs of Nothing -> "" Just arg -> " . " ++ arg) ++ ") " ++@@ -133,10 +140,10 @@ showVal (IOPrim _) = "<IO primitive>" showVal (Port _) = "<IO port>" showVal (Socket _) = "<IO socket>"-showVal (Delay {obj = o, closure = _, tag = _}) = "<promise>" ++ (show o)+showVal (Delay {obj = o, closure = _, tag = _}) = "<promise>" ++ show o showVal (Vector _ vals) =- "#(" ++ (unwords (map showVal (DIM.elems vals))) ++ ")"+ "#(" ++ unwords (map showVal (DIM.elems vals)) ++ ")" -- True and False at the scheme level @@ -168,20 +175,20 @@ showError :: LispError -> String showError (NumArgs func expected found) = func ++ " expected " ++ show expected ++ " args; got values \"" ++- (unwords (map showVal found)) ++ "\""+ 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)+ 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 (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)-showError (DelCont val) = "delcont value " ++ (show val)+ "vector index out of bounds: " ++ show n +++ " not in [0.." ++ show (len - 1) ++ "]"+showError (UserException val) = "user exception " ++ show val+showError (DelCont val) = "delcont value " ++ show val type ThrowsError = Either LispError @@ -192,3 +199,36 @@ liftThrows :: ThrowsError a -> IOThrowsError a liftThrows (Left err) = throwError err liftThrows (Right val) = return val++-- An extended environment: environment plus delimited continuations stuff+-- plus quote-level stuff plus whatever else we may need later++data EEnv = EEnv Env PureEnv [[LispVal]] Integer++eeE :: EEnv -> Env+eeE (EEnv e _ _ _) = e++eePE :: EEnv -> PureEnv+eePE (EEnv _ e _ _) = e++eeDC :: EEnv -> [[LispVal]]+eeDC (EEnv _ _ d _) = d++eeQL :: EEnv -> Integer+eeQL (EEnv _ _ _ q) = q++eeNewE :: EEnv -> Env -> EEnv+eeNewE (EEnv _ pe d q) e = EEnv e pe d q++eeNewPE :: EEnv -> PureEnv -> EEnv+eeNewPE (EEnv e _ d q) pe = EEnv e pe d q++eeNewDC :: EEnv -> [[LispVal]] -> EEnv+eeNewDC (EEnv e pe _ q) d = EEnv e pe d q++eeQLIncr, eeQLDecr :: EEnv -> EEnv+eeQLIncr (EEnv e pe d q) = EEnv e pe d (q + 1)+eeQLDecr (EEnv e pe d q) = EEnv e pe d (q - 1)++progError :: String -> a+progError = error . ("internal error at " ++)
Parser.hs view
@@ -18,7 +18,7 @@ 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.16 2009-08-06 05:05:15 uwe Exp $ -}+$Id: parser.hs,v 1.17 2010-01-05 05:23:34 uwe Exp $ -} module Parser (readExpr, readExprList, readNumber, specialSymbolChars) where import Prelude@@ -36,11 +36,7 @@ -- 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 ' '+hashbang = char '#' >> char '!' >> many (noneOf "\r\n") >> return ' ' -- semicolon to end-of-line, the oldest style of lisp comment @@ -55,6 +51,7 @@ -- This is not quite R6RS-compliant: R6RS allows '.' +specialSymbolChars :: String specialSymbolChars = "!$%&*+-/:<=>?@^_~" symbol :: Parser Char@@ -70,18 +67,18 @@ namedChar :: Parser Char namedChar =- do name <- (string "alarm"+ do name <- string "alarm" <|> string "backspace" <|> string "delete" <|> string "esc" <|> string "linefeed"- <|> (TPCP.try (string "newline"))+ <|> TPCP.try (string "newline") <|> string "nul" <|> string "page" <|> string "return" <|> string "space" <|> string "tab"- <|> string "vtab")+ <|> string "vtab" case name of "nul" -> return (chr 0) "alarm" -> return (chr 7)@@ -95,12 +92,13 @@ "esc" -> return (chr 27) "space" -> return ' ' "delete" -> return (chr 127)+ _ -> progError "namedChar" parseChar :: Parser LispVal parseChar = do char '#' char '\\'- c <- (TPCP.try controlChar) <|> (TPCP.try namedChar) <|> anyChar+ c <- TPCP.try controlChar <|> TPCP.try namedChar <|> anyChar return (Char c) -- This is not quite R6RS-compliant: R6RS requires a hex escape spec,@@ -128,12 +126,13 @@ 't' -> lispTrue 'T' -> lispTrue 'f' -> lispFalse- 'F' -> lispFalse)+ 'F' -> lispFalse+ _ -> progError "parseBool") parseString :: Parser LispVal parseString = do char '"'- x <- many (escChar <|> (noneOf "\""))+ x <- many (escChar <|> noneOf "\"") char '"' return (String x) @@ -145,19 +144,19 @@ readBaseInt :: Integer -> String -> Integer readBaseInt b s = foldl ma 0 s- where ma v1 v2 = b*v1 + (toInteger (digitToInt v2))+ 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)+ 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+ let base = case b of 'b' -> 2 'B' -> 2 'o' -> 8@@ -165,7 +164,8 @@ 'd' -> 10 'D' -> 10 'x' -> 16- 'X' -> 16)+ 'X' -> 16+ _ -> progError "parseHdr" return (s, base) baseDigits :: Integer -> String@@ -173,6 +173,7 @@ baseDigits 8 = "01234567" baseDigits 10 = "0123456789" baseDigits 16 = "0123456789abcdefABCDEF"+baseDigits _ = progError "baseDigits" int :: String int = "int"@@ -200,7 +201,7 @@ parseExp :: Integer -> Parser Integer parseExp b =- do if b == 16 then (oneOf "xX") else (oneOf "eExX")+ do oneOf (if b == 16 then "xX" else "eExX") s <- option '+' (oneOf "+-") num <- many1 (oneOf (baseDigits b)) let e = readBaseInt b num@@ -210,7 +211,7 @@ 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))+ | otherwise = b * powi b (e - 1) pow :: Integer -> Integer -> Double pow b e =@@ -223,12 +224,12 @@ parseIntOrFlt :: Parser LispVal parseIntOrFlt = do (s, b) <- parseHdr- (ip, fp) <- (parseF1 b) <|> (parseF2 b)+ (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)+ 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)) @@ -253,7 +254,7 @@ else if ns < 0 then myRatNInf else myRatNaN- if (denominator val) == 1+ if denominator val == 1 then return (IntNumber (numerator val)) else return (RatNumber val) @@ -261,18 +262,19 @@ 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"))+ 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)+ "+nan.0" -> return (FltNumber myFltNaN)+ "-nan.0" -> return (FltNumber myFltNaN)+ "+inf.0" -> return (FltNumber myFltPInf)+ "-inf.0" -> return (FltNumber myFltNInf)+ _ -> progError "parseNaNInf" parseNumber :: Parser LispVal-parseNumber = (TPCP.try parseNaNInf) <|> (TPCP.try parseRat) <|> parseIntOrFlt+parseNumber = TPCP.try parseNaNInf <|> TPCP.try parseRat <|> parseIntOrFlt -- Parsers for the abbreviations for the various kinds of quoting entities: -- '<datum> => (quote <datum>)@@ -306,9 +308,9 @@ return (List [Symbol "unquote-splicing", x]) parseQuoted :: Parser LispVal-parseQuoted = (TPCP.try parseUQS)- <|> (TPCP.try parseUQ)- <|> (TPCP.try parseQQ)+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@@ -327,21 +329,22 @@ skipMany space char ')' if isl tl- then return (List (hd ++ (unpl tl)))+ then return (List (hd ++ unpl tl)) else if isdl tl- then return (DottedList (hd ++ (unpdlh tl)) (unpdlt 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+ not (sym == "unquote" || sym == "unquote-splicing") isl (List _) = True isl _ = False unpl (List l) = l+ unpl _ = progError "parseDottedList/unpl" isdl (DottedList _ _) = True isdl _ = False unpdlh (DottedList h _) = h+ unpdlh _ = progError "parseDottedList/unpdlh" unpdlt (DottedList _ t) = t+ unpdlt _ = progError "parseDottedList/unpdlt" -- 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.@@ -369,15 +372,15 @@ return (Vector (toInteger (length vals)) (DIM.fromAscList (addkey 0 vals))) where addkey _ [] = []- addkey n (v:vs) = (n, v):(addkey (n+1) vs)+ 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)+ <|> TPCP.try parseBool+ <|> TPCP.try parseChar+ <|> TPCP.try parseNumber+ <|> TPCP.try parseVector+ <|> TPCP.try parseSymbol <|> parseQuoted <|> parseDottedList @@ -392,8 +395,7 @@ readExprList :: String -> ThrowsError [LispVal] readExprList =- readOrThrow ((optional hashbang) >>- (skipMany spaces) >>+ readOrThrow (optional hashbang >> skipMany spaces >> endBy parseExpr (spaces <|> eof)) -- Parser for just numbers, for internally converting strings to numbers;
WriteNumber.hs view
@@ -18,8 +18,10 @@ 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.15 2009-08-06 05:05:15 uwe Exp $ -}+$Id: writenumber.hs,v 1.18 2010-01-18 00:08:49 uwe Exp $ -} +{-# LANGUAGE FlexibleContexts #-}+ module WriteNumber (writeNum, ilogb) where import Prelude import Numeric@@ -39,6 +41,7 @@ prefix 8 = "#o" prefix 10 = "" -- implicit decimal, or "#d" if explicit prefix is desired prefix 16 = "#x"+prefix _ = progError "writeNumber/prefix" -- Exponent marker for floating-point numbers in scientific notation: -- if we just use 'e' all the time, it makes base-16 numbers ambiguous,@@ -57,7 +60,7 @@ | otherwise = sign (n*d) d2c :: Int -> Char-d2c d = ("0123456789abcdef" !! d)+d2c = ("0123456789abcdef" !!) shi :: Integer -> Integer -> String shi b n = showIntAtBase b d2c n ""@@ -68,7 +71,7 @@ ilogb :: Integer -> Integer -> Integer ilogb b n | n < 0 = ilogb b (- n) | n < b = 0- | otherwise = (up 1) - 1+ | otherwise = up 1 - 1 where up a = if n < (b ^ a) then bin (quot a 2) a else up (2*a)@@ -87,24 +90,25 @@ writeInt :: Integer -> Integer -> Maybe Integer -> String writeInt n b p = let pval = fromJust p- nval = (shi b (abs n))- hdr = (prefix b) ++ (sign n)+ 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')+ 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)+isSpRat n = n == myRatNaN || n == myRatPInf || n == myRatNInf -writeSpRat :: Rational -> [Char]+writeSpRat :: Rational -> String writeSpRat n | n == myRatNaN = "0/0" | n == myRatPInf = "1/0" | n == myRatNInf = "-1/0"+ | otherwise = progError "writeNumber/SpRat" -- this is pretty complicated, but it's all pure, and because haskell -- is lazy only those parts which are needed will get evaluated@@ -122,19 +126,19 @@ nf = nr * pfrac (nj, ns) = quotRem nf ad nt = 2*ns- ng = if (nt < ad) || ((nt == ad) && (even nj)) then nj else nj + 1+ 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)+ 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)+ 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)) ++ "."+ 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@@ -146,12 +150,12 @@ 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)+ lb0 = fromInteger (iln - ild) / logBase 2.0 (fromInteger b) :: Double+ lb1 = floor lb0 rb = fromInteger b sn1 = if lb1 >= 0- then (n / (fromInteger (b ^ lb1)))- else (n * (fromInteger (b ^ (-lb1))))+ then n / fromInteger (b ^ lb1)+ else n * fromInteger (b ^ (-lb1)) (sn2, lb2) = if sn1 >= 1 then (sn1, lb1) else (sn1 * rb, lb1 - 1)@@ -162,17 +166,17 @@ writeRatE :: Rational -> Integer -> Integer -> String writeRatE num b p = let (sn, se) = normTo (abs num) b- snr = sn/(fromInteger 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)+ str = writeRatF (sn * signum num) b (Just (abs p)) ++ ssuf se+ strr = writeRatF (snr * signum num) b (Just (abs p)) ++ ssuf ser in if num == 0- then (writeRatF (0%1) b (Just (abs p))) ++ (ssuf 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)+ where ssuf e = emark b ++ sign e ++ shi b (abs e)+ noround = chek . takeWhile (/= '.') chek ('#':_:rest) = chek rest chek ('-':rest) = chek rest chek "10" = False@@ -181,7 +185,7 @@ -- The non-finite floating-point numbers get treated specially. isSpFlt :: RealFloat a => a -> Bool-isSpFlt n = (isNaN n) || (isInfinite n)+isSpFlt n = isNaN n || isInfinite n writeSpFlt :: RealFloat a => a -> String writeSpFlt n | n > 0 = "+inf.0"@@ -191,62 +195,55 @@ 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)))))+ 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))+ 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)+goodBase b = b == 2 || b == 8 || b == 10 || b == 16 +badBase :: MonadError LispError m => Integer -> m b badBase b =- throwError (Default ("bad base " ++ (show b) ++ " in number->string"))+ throwError (Default ("bad base " ++ show b ++ " in number->string")) -writeNum :: [LispVal] -> ThrowsError LispVal+rStr :: Monad m => String -> m LispVal+rStr = return . String -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+wrI :: MonadError LispError m =>+ Integer -> Integer -> Maybe Integer -> m LispVal+wrI n b p = if goodBase b then rStr (writeInt n b 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+wrR :: MonadError LispError m =>+ Rational -> Integer -> Maybe Integer -> m LispVal+wrR n b p | isSpRat n = rStr (writeSpRat n)+ | goodBase b = rStr (writeRatF n b p)+ | otherwise = 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+wrF :: MonadError LispError m =>+ Double -> Integer -> Maybe Integer -> m LispVal+wrF n b p | isSpFlt n = rStr (writeSpFlt n)+ | goodBase b = rStr (writeFlt n b p)+ | otherwise = badBase b +writeNum :: [LispVal] -> ThrowsError LispVal+writeNum [IntNumber n] = wrI n 10 Nothing+writeNum [IntNumber n, IntNumber b] = wrI n b Nothing+writeNum [IntNumber n, IntNumber b, IntNumber p] = wrI n b (Just p)++writeNum [RatNumber n] = wrR n 10 Nothing+writeNum [RatNumber n, IntNumber b] = wrR n b Nothing+writeNum [RatNumber n, IntNumber b, IntNumber p] = wrR n b (Just p)++writeNum [FltNumber n] = wrF n 10 Nothing+writeNum [FltNumber n, IntNumber b] = wrF n b Nothing+writeNum [FltNumber n, IntNumber b, IntNumber p] = wrF n b (Just p)+ writeNum badArgList = if length badArgList <= 3- then throwError (TypeMismatch "number->string" "number" (badArgList !! 0))+ then throwError (TypeMismatch "number->string" "number" (head badArgList)) else throwError (NumArgs "number->string" 3 badArgList)
− delTEST.scm
@@ -1,642 +0,0 @@-; (load "delcont.scm")--(defmacro (sandbox . expr)- (let ((err (gensym)))- `(guard- (,err ((begin (write-string "caught exception '")- (display ,err)- (write-string "'\n")- #t)))- ,@expr)))--; for mzscheme, replace the above definition of sandbox with-; (define (sandbox . expr) #t)-; it won't catch exceptions, but then mzscheme doesn't produce-; any, except for the intentional syntax error at the end--(write-string "all answers are checked against mzscheme\n")--(write-string "examples from community.schemewiki.org\n")--(write-string "r should be 6\t\t")-(sandbox- (display (+ 1 (RESET (+ 2 3))))- (newline))--(write-string "r should be (1 2)\t")-(sandbox- (display (cons 1 (RESET (cons 2 '()))))- (newline))--(write-string "r should be 4\t\t")-(sandbox- (display (+ 1 (RESET (+ 2 (SHIFT k 3)))))- (newline))--(write-string "r should be (1 3)\t")-(sandbox- (display (cons 1 (RESET (cons 2 (SHIFT k (cons 3 '()))))))- (newline))--(write-string "r should be 10\t\t")-(sandbox- (display (+ 1 (RESET (+ 2 (SHIFT k (+ 3 (k 4)))))))- (newline))--(write-string "r should be 14\t\t")-(sandbox- (display (+ 1 (RESET (+ 2 (SHIFT k (+ 3 (k 5) (k 1)))))))- (newline))--(write-string "r should be (1 3 2 4)\t")-(sandbox- (display (cons 1 (RESET (cons 2 (SHIFT k (cons 3 (k (cons 4 '()))))))))- (newline))--(write-string "r should be (1 3 2 2 4)\t")-(sandbox- (display (cons 1 (RESET (cons 2 (SHIFT k (cons 3 (k (k (cons 4 '())))))))))- (newline))--(write-string "multiple SHIFTs\n")--(write-string "r should be 2\t\t")-(sandbox- (RESET (display (begin (SHIFT k1 (k1 1)) (SHIFT k2 (k2 2)))))- (newline))--; haskeem fails this -- restart issue-(write-string "r should be 12\t\t")-(sandbox- (RESET (begin (display (SHIFT k1 (k1 1))) (display (SHIFT k2 (k2 2)))))- (newline))--(write-string "r should be 12\t\t")-(sandbox- (RESET (display (SHIFT k1 (k1 1))) (display (SHIFT k2 (k2 2))))- (newline))--(write-string "r0 should be 134234\t")-(sandbox- (RESET0 (begin (SHIFT0 k1 (begin (k1 (display 1)) (k1 (display 2))))- (SHIFT0 k2 (begin (k2 (display 3)) (k2 (display 4))))))- (newline))--(write-string "r0 should be 134234\t")-(sandbox- (RESET0 (begin (SHIFT0 k1 (k1 (display 1)) (k1 (display 2)))- (SHIFT0 k2 (k2 (display 3)) (k2 (display 4)))))- (newline))--(write-string "r0 should be 134234\t")-(sandbox- (RESET0 (SHIFT0 k1 (k1 (display 1)) (k1 (display 2)))- (SHIFT0 k2 (k2 (display 3)) (k2 (display 4))))- (newline))--(write-string "r0 should be 13564562356456\n\t ")-(sandbox- (RESET0 (begin (SHIFT0 k1 (begin (k1 (display 1)) (k1 (display 2))))- (SHIFT0 k2 (begin (k2 (display 3)) (k2 (display 4))))- (SHIFT0 k3 (begin (k3 (display 5)) (k3 (display 6))))))- (write-string "\n\t ")- (RESET0 (begin (SHIFT0 k1 (k1 (display 1)) (k1 (display 2)))- (SHIFT0 k2 (k2 (display 3)) (k2 (display 4)))- (SHIFT0 k3 (k3 (display 5)) (k3 (display 6)))))- (write-string "\n\t ")- (RESET0 (SHIFT0 k1 (k1 (display 1)) (k1 (display 2)))- (SHIFT0 k2 (k2 (display 3)) (k2 (display 4)))- (SHIFT0 k3 (k3 (display 5)) (k3 (display 6))))- (newline))--(write-string "r should be 57\t\t")-(sandbox- (display (+ 1 (RESET (+ 2 (SHIFT k1 (+ 3- (k1 5)- (k1 1)- (RESET (* 10 (SHIFT k2 (+ 3 (k2 4)))))- ))))))- (newline))--(write-string "r should be 59\t\t")-(sandbox- (display (+ 1 (RESET (+ 2 (SHIFT k1 (+ 3- (k1 5)- (k1 1)- (RESET (* 10 (SHIFT k2 (+ (k1 3)- (k2 4)))))- ))))))- (newline))--; haskeem fails the following nine -- restart issue--(write-string "r should be 1 3 2\t")-(sandbox- (RESET (begin (write-string "1 ")- (SHIFT c (begin (c 'ignore)- (write-string "2 ")))- (write-string "3 ")))- (newline))-(write-string "r should be 1 3 2\t")-(sandbox- (RESET (begin (write-string "1 ")- (SHIFT c (c 'ignore) (write-string "2 "))- (write-string "3 ")))- (newline))-(write-string "r should be 1 3 2\t")-(sandbox- (RESET (write-string "1 ")- (SHIFT c (c 'ignore) (write-string "2 "))- (write-string "3 "))- (newline))--(write-string "r should be 1 2 3\t")-(sandbox- (RESET (begin (write-string "1 ")- (SHIFT c (begin (write-string "2 ")- (c 'ignore)))- (write-string "3 ")))- (newline))-(write-string "r should be 1 2 3\t")-(sandbox- (RESET (begin (write-string "1 ")- (SHIFT c (write-string "2 ") (c 'ignore))- (write-string "3 ")))- (newline))-(write-string "r should be 1 2 3\t")-(sandbox- (RESET (write-string "1 ")- (SHIFT c (write-string "2 ") (c 'ignore))- (write-string "3 "))- (newline))--(write-string "r should be 1 3 2 3\t")-(sandbox- (RESET (begin (write-string "1 ")- (SHIFT c (begin (c 'ignore)- (write-string "2 ")- (c 'ignore)))- (write-string "3 ")))- (newline))-(write-string "r should be 1 3 2 3\t")-(sandbox- (RESET (begin (write-string "1 ")- (SHIFT c (c 'ignore) (write-string "2 ") (c 'ignore))- (write-string "3 ")))- (newline))-(write-string "r should be 1 3 2 3\t")-(sandbox- (RESET (write-string "1 ")- (SHIFT c (c 'ignore) (write-string "2 ") (c 'ignore))- (write-string "3 "))- (newline))--(write-string "from Shan, \"Shift to Control\"\n")--(write-string "r should be (a)\t")-(sandbox- (display (RESET (cons 'a (RESET (SHIFT f (SHIFT g '()))))))- (newline))--(write-string "r0 should be ()\t\t")-(sandbox- (display (RESET0 (cons 'a (RESET0 (SHIFT0 f (SHIFT0 g '()))))))- (newline))--(write-string "r should be (a)\t")-(sandbox- (display (RESET (let ((y (SHIFT f (cons 'a (f '()))))) (SHIFT g y))))- (newline))--(write-string "p should be ()\t\t")-(sandbox- (display (PROMPT (let ((y (CONTROL f (cons 'a (f '()))))) (CONTROL g y))))- (newline))--; Shan sez this is an infinite loop... Kiselyov turns this into a printing-; loop by adding (display) somewhere, have to see if I can replicate that.-; I dunno if the name has to be 'f' in both CONTROL parts--;(PROMPT (begin (CONTROL f (begin (f 0) (f 0)))-; (CONTROL f (begin (f 0) (f 0)))))--;;;(write-string "should be 132342344234442344442344444234444442344...\n\t ")-;;; with RESET2 it /is/ an infinite loop, just not the desired one...-;;; it produces 1313131313... instead-;;; I think this is actually the same partially-evaluated-thunk issue-;;; as with the other tests which are failing-;;;(PROMPT (begin (CONTROL f (begin (f (display 1)) (f (display 2))))-;;; (CONTROL f (begin (f (display 3)) (f (display 4))))))-;;;(newline)--(write-string "r should be (a)\t")-(sandbox- (display (RESET (let ((y (SHIFT f (cons 'a (f '()))))) (SHIFT g y))))- (newline))--(write-string "r0 should be (a)\t")-(sandbox- (display (RESET0 (let ((y (SHIFT0 f (cons 'a (f '()))))) (SHIFT0 g y))))- (newline))--(write-string "p should be ()\t\t")-(sandbox- (display (PROMPT (let ((y (CONTROL f (cons 'a (f '()))))) (CONTROL g y))))- (newline))--(write-string "p0 should be ()\t\t")-(sandbox- (display- (RESET (PROMPT0 (let ((y (CONTROL0 f (cons 'a (f '()))))) (CONTROL0 g y)))))- (newline))--(write-string "r should be (a b)\t")-(sandbox- (display- (RESET- (RESET (cons 'a (RESET- (let ((y (SHIFT f (SHIFT g (cons 'b (f '()))))))- (SHIFT h y)))))))- (newline))--(write-string "p should be (a)\t")-(sandbox- (display- (PROMPT- (PROMPT (cons 'a (PROMPT- (let ((y (CONTROL f (CONTROL g (cons 'b (f '()))))))- (CONTROL h y)))))))- (newline))--(write-string "r0 should be (b)\t")-(sandbox- (display- (RESET0- (RESET0 (cons 'a (RESET0- (let ((y (SHIFT0 f (SHIFT0 g (cons 'b (f '()))))))- (SHIFT0 h y)))))))- (newline))--; haskeem fails this -- UNKNOWN ISSUE! TODO: investigate!--(write-string "p0 should be ()\t\t")-(sandbox- (display- (PROMPT0- (PROMPT0 (cons 'a (PROMPT0- (let ((y (CONTROL0 f (CONTROL0 g (cons 'b (f '()))))))- (CONTROL0 h y)))))))- (newline))--(write-string "two-armed tests\n")-(write-string "test 1: non-trivial SHIFT only in false arm of if\n")-(define (doit1 flag)- (if flag- (write-string "r should be (1 3)\t")- (write-string "r should be (1 4 2 5)\t"))- (sandbox- (display- (cons 1 (RESET (cons 2 (if flag- (SHIFT k1 (cons 3 '()))- (SHIFT k2 (cons 4 (k2 (cons 5 '())))))))))- (newline)))--(doit1 #f)-(doit1 #t)--(write-string "test 2: reverse of previous\n")-(define (doit2 flag)- (if flag- (write-string "r should be (1 4 2 5)\t")- (write-string "r should be (1 3)\t"))- (sandbox- (display- (cons 1 (RESET (cons 2 (if flag- (SHIFT k2 (cons 4 (k2 (cons 5 '()))))- (SHIFT k1 (cons 3 '())))))))- (newline)))--(doit2 #f)-(doit2 #t)--(write-string "test 3: wrong? expansion of test 1\n")--(define (doit3 flag)- (write-string "r should be (1 4 3)\t") ; independent of flag- (sandbox- (display- (cons 1- (let ((k2 (lambda (v2)- (let ((k1 (lambda (v1)- (RESET (cons 2 (if flag v1 v2))))))- (cons 3 '())))))- (RESET (cons 4 (k2 (cons 5 '())))))))- (newline)))--(doit3 #f)-(doit3 #t)--(write-string "test 4: expansion of test 2\n")-(define (doit4 flag)- (if flag- (write-string "r should be (1 4 2 3)\t")- (write-string "r should be (1 4 2 5)\t"))- (sandbox- (display- (cons 1- (let ((k2 (lambda (v2)- (RESET (cons 2 (if flag (cons 3 '()) v2))))))- (RESET (cons 4 (k2 (cons 5 '())))))))- (newline)))--(doit4 #f)-(doit4 #t)--(write-string "test 5: modified version, with (SHIFT) in both arms of (if)\n")-(define (doit5 flag)- (if flag- (write-string "r should be (1 3 2 4)\t")- (write-string "r should be (1 5 2 6)\t"))- (sandbox- (display- (cons 1- (RESET (cons 2 (if flag- (SHIFT k1 (cons 3 (k1 (cons 4 '()))))- (SHIFT k2 (cons 5 (k2 (cons 6 '())))))))))- (newline)))--(doit5 #f)-(doit5 #t)--(write-string- "test 6: modified version of test 5, with (if) lifted out of (RESET)\n")--(define (doit6 flag)- (if flag- (write-string "r should be (1 3 2 4)\t")- (write-string "r should be (1 5 2 6)\t"))- (sandbox- (display- (cons 1- (if flag- (RESET (cons 2 (SHIFT k1 (cons 3 (k1 (cons 4 '()))))))- (RESET (cons 2 (SHIFT k2 (cons 5 (k2 (cons 6 '())))))))))- (newline)))--(doit6 #f)-(doit6 #t)--(write-string "examples from Queinnec, augmented to test all versions\n")--(write-string "PROMPT/CONTROL examples\n")-(write-string "should be 3\t\t")-(sandbox- (display (PROMPT (* 2 (CONTROL f 3))))- (newline))--(write-string "should be 30\t\t")-(sandbox- (display (PROMPT (* 2 (CONTROL f (* 5 (f 3))))))- (newline))--(write-string "should be 12\t\t")-(sandbox- (display (PROMPT (* 2 (CONTROL f (f (f 3))))))- (newline))--(write-string "should be 6\t\t")-(sandbox- (display ((PROMPT (* 2 (CONTROL f f))) 3))- (newline))--(write-string "should be 35\t\t")-(sandbox- (display (PROMPT (* 5- (PROMPT (* 2- (CONTROL f2 (* 3 (CONTROL f3 7))))))))- (newline))--; haskeem quasi-fails this: because it's a (lambda () ...), it escapes,-; and so at the end there's an uncaught exception which however carries-; along the correct value as its payload. So I think haskeem would handle-; this correctly if there were an implicit top-level catcher--(write-string "should be 7\t\t")-(sandbox- (display (PROMPT (* 5 (- (PROMPT (* 2- (CONTROL f2 (lambda ()- (* 3 (CONTROL f3 7))))))))))- (newline))--(write-string "should be 21\t\t")-(sandbox- (display (PROMPT (* 5- ((lambda (x) (CONTROL f1 x))- (* 3 (CONTROL f2 (* 2 (f2 7))))))))- (newline))--(write-string "PROMPT0/CONTROL0 examples\n")-(write-string "should be 3\t\t")-(sandbox- (display (PROMPT0 (* 2 (CONTROL0 f 3))))- (newline))--(write-string "should be 30\t\t")-(sandbox- (display (PROMPT0 (* 2 (CONTROL0 f (* 5 (f 3))))))- (newline))--(write-string "should be 12\t\t")-(sandbox- (display (PROMPT0 (* 2 (CONTROL0 f (f (f 3))))))- (newline))--(write-string "should be 6\t\t")-(sandbox- (display ((PROMPT0 (* 2 (CONTROL0 f f))) 3))- (newline))--(write-string "should be 7\t\t")-(sandbox- (display (PROMPT0 (* 5- (PROMPT0 (* 2- (CONTROL0 f2 (* 3 (CONTROL0 f3 7))))))))- (newline))--(write-string "should be 7\t\t")-(sandbox- (display (PROMPT0 (* 5 (- (PROMPT0 (* 2- (CONTROL0 f2 (lambda ()- (* 3 (CONTROL0 f3 7))))))))))- (newline))--; There's something odd with this test: in mzscheme, it prints the-; result 21, then the whole rest of the test vanishes; apparently-; enough of the surrounding context is sucked up that the rest of the-; world just vanishes. If I surround this with a (RESET ...), the-; test continues, but this doesn't print anything. Hmmm!--(write-string "should be 21\t\t")-(sandbox- (display (PROMPT0 (* 5- ((lambda (x) (CONTROL0 f1 x))- (* 3 (CONTROL0 f2 (* 2 (f2 7))))))))- (newline))--(write-string "RESET/SHIFT examples\n")-(write-string "should be 3\t\t")-(sandbox- (display (RESET (* 2 (SHIFT f 3))))- (newline))--(write-string "should be 30\t\t")-(sandbox- (display (RESET (* 2 (SHIFT f (* 5 (f 3))))))- (newline))--(write-string "should be 12\t\t")-(sandbox- (display (RESET (* 2 (SHIFT f (f (f 3))))))- (newline))--(write-string "should be 6\t\t")-(sandbox- (display ((RESET (* 2 (SHIFT f f))) 3))- (newline))--(write-string "should be 35\t\t")-(sandbox- (display (RESET (* 5- (RESET (* 2- (SHIFT f2 (* 3 (SHIFT f3 7))))))))- (newline))--(write-string "should be 7\t\t")-(sandbox- (display (RESET (* 5 (- (RESET (* 2- (SHIFT f2 (lambda ()- (* 3 (SHIFT f3 7))))))))))- (newline))--(write-string "should be 42\t\t")-(sandbox- (display (RESET (* 5- ((lambda (x) (SHIFT f1 x))- (* 3 (SHIFT f2 (* 2 (f2 7))))))))- (newline))--(write-string "RESET0/SHIFT0 examples\n")-(write-string "should be 3\t\t")-(sandbox- (display (RESET0 (* 2 (SHIFT0 f 3))))- (newline))--(write-string "should be 30\t\t")-(sandbox- (display (RESET0 (* 2 (SHIFT0 f (* 5 (f 3))))))- (newline))--(write-string "should be 12\t\t")-(sandbox- (display (RESET0 (* 2 (SHIFT0 f (f (f 3))))))- (newline))--(write-string "should be 6\t\t")-(sandbox- (display ((RESET0 (* 2 (SHIFT0 f f))) 3))- (newline))--(write-string "should be 7\t\t")-(sandbox- (display (RESET0 (* 5- (RESET0 (* 2- (SHIFT0 f2 (* 3 (SHIFT0 f3 7))))))))- (newline))--(write-string "should be 7\t\t")-(sandbox- (display (RESET0 (* 5 (- (RESET0 (* 2- (SHIFT0 f2 (lambda ()- (* 3 (SHIFT0 f3 7))))))))))- (newline))--(write-string "should be 42\t\t")-(sandbox- (display (RESET0 (* 5- ((lambda (x) (SHIFT0 f1 x))- (* 3 (SHIFT0 f2 (* 2 (f2 7))))))))- (newline))--(write-string "r something actually useful! a small table of factorials\n")--; Eventually we want to be able to use code like this:--; (defmacro (range from step to)-; (let ((f (gensym))-; (i (gensym)))-; `(SHIFT ,f-; (do ((,i ,from (+ ,i ,step)))-; ((> ,i ,to) #f)-; (,f ,i)))))-;-; (RESET (begin (display (my-fact (range 1 3 16))) (newline)))--; Just to show I've got nothing up my sleeve, here is a perfectly cromulent-; function; we could equally well use the built-in (factorial) function--(define (my-fact n)- (if (<= n 0)- 1- (* n (my-fact (- n 1)))))--(define from 1)-(define to 21)-(define step 3)--(sandbox- (RESET (display (my-fact - (SHIFT f- (do ((i from (+ i step)))- ((> i to) #f)- (write-string (number->string i))- (write-string "! =\t")- (f i)))))- (newline)))--; This one is specific to haskeem, because the macro RESET doesn't start-; the thunk in the middle, but rather at the beginning; that makes the-; ping-pong possible--(write-string- "These rely on the RESET thunk being re-evaluated from the beginning,\n")-(write-string- "so strictly speaking both are wrong. So I don't know what the answers\n")-(write-string- "\"should be\"... but they look plausible\n")-(define (doit7 flag)- (sandbox- (display- (cons 1- (RESET (cons 2 (if flag- (SHIFT k1 (set! flag (not flag))- (cons 3 (k1 (cons 4 '()))))- (SHIFT k2 (set! flag (not flag))- (cons 5 (k2 (cons 6 '())))))))))- (newline)))--; it's hard to say if these are right... both rely on a wrong implementation-; of the thunk stuff--(doit7 #f) ; (1 5 3 2 6) -- mzscheme sez (1 5 2 6)-(doit7 #t) ; (1 3 5 2 4) -- mzscheme sez (1 3 2 4)--(write-string- "syntax error coming up! should be an error... this'll kill mzscheme\n")--(sandbox (display (+ 1 (RESET (+ 2 (SHIFT (+ k 1) 3))))))-(write-string- "haskeem should have caught the exception raised by the syntax error\n")
delcont.scm view
@@ -1,5 +1,5 @@ ; Copyright 2009 Uwe Hollerbach <uh@alumni.caltech.edu>-; $Id: delcont.scm,v 1.14 2009-08-02 03:18:24 uwe Exp $+; $Id: delcont.scm,v 1.15 2009-08-09 05:38:50 uwe Exp $ ; BSD3 ; Delimited continuations: these look simpler than call/cc, just a fairly@@ -30,9 +30,13 @@ ; there are multiple args... gotta be a better way to do that? ; Still, this works and allows testing. +; These are renamed to reset/m etc, all with trailing /m, to denote+; that they're macros, and to not interfere with the native versions+; of at least reset and shift.+ (define *delcont-list* '()) -(defmacro (reset . expr)+(defmacro (reset/m . expr) (letrec* ((id (gensym)) (ret (gensym)) (err (gensym))@@ -43,14 +47,14 @@ (r-aux (lambda (ex) (cond ((not (list? ex)) ex) ((null? ex) ex)- ((or (eqv? 'shift (car ex))- (eqv? 'shift0 (car ex))- (eqv? 'control (car ex))- (eqv? 'control0 (car ex)))- (let ((f1 (or (eqv? 'shift (car ex))- (eqv? 'shift0 (car ex))))- (f2 (or (eqv? 'shift (car ex))- (eqv? 'control (car ex)))))+ ((or (eqv? 'shift/m (car ex))+ (eqv? 'shift0/m (car ex))+ (eqv? 'control/m (car ex))+ (eqv? 'control0/m (car ex)))+ (let ((f1 (or (eqv? 'shift/m (car ex))+ (eqv? 'shift0/m (car ex))))+ (f2 (or (eqv? 'shift/m (car ex))+ (eqv? 'control/m (car ex))))) (set! flag #t) (if (and (> (length ex) 2) (symbol? (cadr ex)))@@ -96,21 +100,21 @@ ; aliases -- in this macro-based approach, they should be just sugar -(define reset0 reset)-(define prompt reset)-(define prompt0 reset)+(define reset0/m reset/m)+(define prompt/m reset/m)+(define prompt0/m reset/m) ; stupid-catchers -(defmacro (shift sym expr)- (raise "oops, naked delcont form" 'shift sym expr))+(defmacro (shift/m sym expr)+ (raise "oops, naked delcont form" 'shift/m sym expr)) -(defmacro (shift0 sym expr)- (raise "oops, naked delcont form" 'shift0 sym expr))+(defmacro (shift0/m sym expr)+ (raise "oops, naked delcont form" 'shift0/m sym expr)) -(defmacro (control sym expr)- (raise "oops, naked delcont form" 'control sym expr))+(defmacro (control/m sym expr)+ (raise "oops, naked delcont form" 'control/m sym expr)) -(defmacro (control0 sym expr)- (raise "oops, naked delcont form" 'control0 sym expr))+(defmacro (control0/m sym expr)+ (raise "oops, naked delcont form" 'control0/m sym expr))
deltest.scm view
@@ -1,3 +1,8 @@+; For the time being, comment out the reset0, prompt, and prompt0 examples:+; there's something fairly fundamental missing in haskeem (but I don't know+; what it is), so it doesn't handle these at all well. The reset/shift+; examples are all correct, except for the restart issue.+ ; (load "delcont.scm") (defmacro (sandbox . expr)@@ -18,98 +23,98 @@ (write-string "examples from community.schemewiki.org\n") -(write-string "r should be 6\t\t")+(write-string "should be 6\t\t") (sandbox (display (+ 1 (reset (+ 2 3)))) (newline)) -(write-string "r should be (1 2)\t")+(write-string "should be (1 2)\t\t") (sandbox (display (cons 1 (reset (cons 2 '())))) (newline)) -(write-string "r should be 4\t\t")+(write-string "should be 4\t\t") (sandbox (display (+ 1 (reset (+ 2 (shift k 3))))) (newline)) -(write-string "r should be (1 3)\t")+(write-string "should be (1 3)\t\t") (sandbox (display (cons 1 (reset (cons 2 (shift k (cons 3 '())))))) (newline)) -(write-string "r should be 10\t\t")+(write-string "should be 10\t\t") (sandbox (display (+ 1 (reset (+ 2 (shift k (+ 3 (k 4))))))) (newline)) -(write-string "r should be 14\t\t")+(write-string "should be 14\t\t") (sandbox (display (+ 1 (reset (+ 2 (shift k (+ 3 (k 5) (k 1))))))) (newline)) -(write-string "r should be (1 3 2 4)\t")+(write-string "should be (1 3 2 4)\t") (sandbox (display (cons 1 (reset (cons 2 (shift k (cons 3 (k (cons 4 '())))))))) (newline)) -(write-string "r should be (1 3 2 2 4)\t")+(write-string "should be (1 3 2 2 4)\t") (sandbox (display (cons 1 (reset (cons 2 (shift k (cons 3 (k (k (cons 4 '()))))))))) (newline)) (write-string "multiple shifts\n") -(write-string "r should be 2\t\t")+(write-string "should be 2\t\t") (sandbox (reset (display (begin (shift k1 (k1 1)) (shift k2 (k2 2))))) (newline)) ; haskeem fails this -- restart issue-(write-string "r should be 12\t\t")+(write-string "should be 12\t\t") (sandbox (reset (begin (display (shift k1 (k1 1))) (display (shift k2 (k2 2))))) (newline)) -(write-string "r should be 12\t\t")+(write-string "should be 12\t\t") (sandbox (reset (display (shift k1 (k1 1))) (display (shift k2 (k2 2)))) (newline)) -(write-string "r0 should be 134234\t")+(write-string "should be 134234\t") (sandbox- (reset0 (begin (shift0 k1 (begin (k1 (display 1)) (k1 (display 2))))- (shift0 k2 (begin (k2 (display 3)) (k2 (display 4))))))+ (reset (begin (shift k1 (begin (k1 (display 1)) (k1 (display 2))))+ (shift k2 (begin (k2 (display 3)) (k2 (display 4)))))) (newline)) -(write-string "r0 should be 134234\t")+(write-string "should be 134234\t") (sandbox- (reset0 (begin (shift0 k1 (k1 (display 1)) (k1 (display 2)))- (shift0 k2 (k2 (display 3)) (k2 (display 4)))))+ (reset (begin (shift k1 (k1 (display 1)) (k1 (display 2)))+ (shift k2 (k2 (display 3)) (k2 (display 4))))) (newline)) -(write-string "r0 should be 134234\t")+(write-string "should be 134234\t") (sandbox- (reset0 (shift0 k1 (k1 (display 1)) (k1 (display 2)))- (shift0 k2 (k2 (display 3)) (k2 (display 4))))+ (reset (shift k1 (k1 (display 1)) (k1 (display 2)))+ (shift k2 (k2 (display 3)) (k2 (display 4)))) (newline)) -(write-string "r0 should be 13564562356456\n\t ")+(write-string "should be 13564562356456\n\t ") (sandbox- (reset0 (begin (shift0 k1 (begin (k1 (display 1)) (k1 (display 2))))- (shift0 k2 (begin (k2 (display 3)) (k2 (display 4))))- (shift0 k3 (begin (k3 (display 5)) (k3 (display 6))))))- (write-string "\n\t ")- (reset0 (begin (shift0 k1 (k1 (display 1)) (k1 (display 2)))- (shift0 k2 (k2 (display 3)) (k2 (display 4)))- (shift0 k3 (k3 (display 5)) (k3 (display 6)))))- (write-string "\n\t ")- (reset0 (shift0 k1 (k1 (display 1)) (k1 (display 2)))- (shift0 k2 (k2 (display 3)) (k2 (display 4)))- (shift0 k3 (k3 (display 5)) (k3 (display 6))))+ (reset (begin (shift k1 (begin (k1 (display 1)) (k1 (display 2))))+ (shift k2 (begin (k2 (display 3)) (k2 (display 4))))+ (shift k3 (begin (k3 (display 5)) (k3 (display 6))))))+ (write-string "\n\t ")+ (reset (begin (shift k1 (k1 (display 1)) (k1 (display 2)))+ (shift k2 (k2 (display 3)) (k2 (display 4)))+ (shift k3 (k3 (display 5)) (k3 (display 6)))))+ (write-string "\n\t ")+ (reset (shift k1 (k1 (display 1)) (k1 (display 2)))+ (shift k2 (k2 (display 3)) (k2 (display 4)))+ (shift k3 (k3 (display 5)) (k3 (display 6)))) (newline)) -(write-string "r should be 57\t\t")+(write-string "should be 57\t\t") (sandbox (display (+ 1 (reset (+ 2 (shift k1 (+ 3 (k1 5)@@ -118,7 +123,7 @@ )))))) (newline)) -(write-string "r should be 59\t\t")+(write-string "should be 59\t\t") (sandbox (display (+ 1 (reset (+ 2 (shift k1 (+ 3 (k1 5)@@ -130,47 +135,47 @@ ; haskeem fails the following nine -- restart issue -(write-string "r should be 1 3 2\t")+(write-string "should be 1 3 2\t\t") (sandbox (reset (begin (write-string "1 ") (shift c (begin (c 'ignore) (write-string "2 "))) (write-string "3 "))) (newline))-(write-string "r should be 1 3 2\t")+(write-string "should be 1 3 2\t\t") (sandbox (reset (begin (write-string "1 ") (shift c (c 'ignore) (write-string "2 ")) (write-string "3 "))) (newline))-(write-string "r should be 1 3 2\t")+(write-string "should be 1 3 2\t\t") (sandbox (reset (write-string "1 ") (shift c (c 'ignore) (write-string "2 ")) (write-string "3 ")) (newline)) -(write-string "r should be 1 2 3\t")+(write-string "should be 1 2 3\t\t") (sandbox (reset (begin (write-string "1 ") (shift c (begin (write-string "2 ") (c 'ignore))) (write-string "3 "))) (newline))-(write-string "r should be 1 2 3\t")+(write-string "should be 1 2 3\t\t") (sandbox (reset (begin (write-string "1 ") (shift c (write-string "2 ") (c 'ignore)) (write-string "3 "))) (newline))-(write-string "r should be 1 2 3\t")+(write-string "should be 1 2 3\t\t") (sandbox (reset (write-string "1 ") (shift c (write-string "2 ") (c 'ignore)) (write-string "3 ")) (newline)) -(write-string "r should be 1 3 2 3\t")+(write-string "should be 1 3 2 3\t") (sandbox (reset (begin (write-string "1 ") (shift c (begin (c 'ignore)@@ -178,13 +183,13 @@ (c 'ignore))) (write-string "3 "))) (newline))-(write-string "r should be 1 3 2 3\t")+(write-string "should be 1 3 2 3\t") (sandbox (reset (begin (write-string "1 ") (shift c (c 'ignore) (write-string "2 ") (c 'ignore)) (write-string "3 "))) (newline))-(write-string "r should be 1 3 2 3\t")+(write-string "should be 1 3 2 3\t") (sandbox (reset (write-string "1 ") (shift c (c 'ignore) (write-string "2 ") (c 'ignore))@@ -193,32 +198,25 @@ (write-string "from Shan, \"Shift to Control\"\n") -(write-string "r should be (a)\t")+(write-string "should be (a)\t\t") (sandbox (display (reset (cons 'a (reset (shift f (shift g '())))))) (newline)) -(write-string "r0 should be ()\t\t")-(sandbox- (display (reset0 (cons 'a (reset0 (shift0 f (shift0 g '()))))))- (newline))+;; (write-string "r0 should be ()\t\t")+;; (sandbox+;; (display (reset0 (cons 'a (reset0 (shift0 f (shift0 g '()))))))+;; (newline)) -(write-string "r should be (a)\t")+(write-string "should be (a)\t\t") (sandbox (display (reset (let ((y (shift f (cons 'a (f '()))))) (shift g y)))) (newline)) -(write-string "p should be ()\t\t")-(sandbox- (display (prompt (let ((y (control f (cons 'a (f '()))))) (control g y))))- (newline))--; Shan sez this is an infinite loop... Kiselyov turns this into a printing-; loop by adding (display) somewhere, have to see if I can replicate that.-; I dunno if the name has to be 'f' in both control parts--;(prompt (begin (control f (begin (f 0) (f 0)))-; (control f (begin (f 0) (f 0)))))+;; (write-string "p should be ()\t\t")+;; (sandbox+;; (display (prompt (let ((y (control f (cons 'a (f '()))))) (control g y))))+;; (newline)) ;;;(write-string "should be 132342344234442344442344444234444442344...\n\t ") ;;; with reset2 it /is/ an infinite loop, just not the desired one...@@ -229,28 +227,28 @@ ;;; (control f (begin (f (display 3)) (f (display 4)))))) ;;;(newline) -(write-string "r should be (a)\t")+(write-string "should be (a)\t\t") (sandbox (display (reset (let ((y (shift f (cons 'a (f '()))))) (shift g y)))) (newline)) -(write-string "r0 should be (a)\t")-(sandbox- (display (reset0 (let ((y (shift0 f (cons 'a (f '()))))) (shift0 g y))))- (newline))+;; (write-string "r0 should be (a)\t")+;; (sandbox+;; (display (reset0 (let ((y (shift0 f (cons 'a (f '()))))) (shift0 g y))))+;; (newline)) -(write-string "p should be ()\t\t")-(sandbox- (display (prompt (let ((y (control f (cons 'a (f '()))))) (control g y))))- (newline))+;; (write-string "p should be ()\t\t")+;; (sandbox+;; (display (prompt (let ((y (control f (cons 'a (f '()))))) (control g y))))+;; (newline)) -(write-string "p0 should be ()\t\t")-(sandbox- (display- (reset (prompt0 (let ((y (control0 f (cons 'a (f '()))))) (control0 g y)))))- (newline))+;; (write-string "p0 should be ()\t\t")+;; (sandbox+;; (display+;; (reset (prompt0 (let ((y (control0 f (cons 'a (f '()))))) (control0 g y)))))+;; (newline)) -(write-string "r should be (a b)\t")+(write-string "should be (a b)\t\t") (sandbox (display (reset@@ -259,41 +257,41 @@ (shift h y))))))) (newline)) -(write-string "p should be (a)\t")-(sandbox- (display- (prompt- (prompt (cons 'a (prompt- (let ((y (control f (control g (cons 'b (f '()))))))- (control h y)))))))- (newline))+;; (write-string "p should be (a)\t")+;; (sandbox+;; (display+;; (prompt+;; (prompt (cons 'a (prompt+;; (let ((y (control f (control g (cons 'b (f '()))))))+;; (control h y)))))))+;; (newline)) -(write-string "r0 should be (b)\t")-(sandbox- (display- (reset0- (reset0 (cons 'a (reset0- (let ((y (shift0 f (shift0 g (cons 'b (f '()))))))- (shift0 h y)))))))- (newline))+;; (write-string "r0 should be (b)\t")+;; (sandbox+;; (display+;; (reset0+;; (reset0 (cons 'a (reset0+;; (let ((y (shift0 f (shift0 g (cons 'b (f '()))))))+;; (shift0 h y)))))))+;; (newline)) ; haskeem fails this -- UNKNOWN ISSUE! TODO: investigate! -(write-string "p0 should be ()\t\t")-(sandbox- (display- (prompt0- (prompt0 (cons 'a (prompt0- (let ((y (control0 f (control0 g (cons 'b (f '()))))))- (control0 h y)))))))- (newline))+;; (write-string "p0 should be ()\t\t")+;; (sandbox+;; (display+;; (prompt0+;; (prompt0 (cons 'a (prompt0+;; (let ((y (control0 f (control0 g (cons 'b (f '()))))))+;; (control0 h y)))))))+;; (newline)) (write-string "two-armed tests\n") (write-string "test 1: non-trivial shift only in false arm of if\n") (define (doit1 flag) (if flag- (write-string "r should be (1 3)\t")- (write-string "r should be (1 4 2 5)\t"))+ (write-string "should be (1 3)\t\t")+ (write-string "should be (1 4 2 5)\t")) (sandbox (display (cons 1 (reset (cons 2 (if flag@@ -307,8 +305,8 @@ (write-string "test 2: reverse of previous\n") (define (doit2 flag) (if flag- (write-string "r should be (1 4 2 5)\t")- (write-string "r should be (1 3)\t"))+ (write-string "should be (1 4 2 5)\t")+ (write-string "should be (1 3)\t\t")) (sandbox (display (cons 1 (reset (cons 2 (if flag@@ -322,7 +320,7 @@ (write-string "test 3: wrong? expansion of test 1\n") (define (doit3 flag)- (write-string "r should be (1 4 3)\t") ; independent of flag+ (write-string "should be (1 4 3)\t") ; independent of flag (sandbox (display (cons 1@@ -339,8 +337,8 @@ (write-string "test 4: expansion of test 2\n") (define (doit4 flag) (if flag- (write-string "r should be (1 4 2 3)\t")- (write-string "r should be (1 4 2 5)\t"))+ (write-string "should be (1 4 2 3)\t")+ (write-string "should be (1 4 2 5)\t")) (sandbox (display (cons 1@@ -355,8 +353,8 @@ (write-string "test 5: modified version, with (shift) in both arms of (if)\n") (define (doit5 flag) (if flag- (write-string "r should be (1 3 2 4)\t")- (write-string "r should be (1 5 2 6)\t"))+ (write-string "should be (1 3 2 4)\t")+ (write-string "should be (1 5 2 6)\t")) (sandbox (display (cons 1@@ -373,8 +371,8 @@ (define (doit6 flag) (if flag- (write-string "r should be (1 3 2 4)\t")- (write-string "r should be (1 5 2 6)\t"))+ (write-string "should be (1 3 2 4)\t")+ (write-string "should be (1 5 2 6)\t")) (sandbox (display (cons 1@@ -388,89 +386,84 @@ (write-string "examples from Queinnec, augmented to test all versions\n") -(write-string "prompt/control examples\n")-(write-string "should be 3\t\t")-(sandbox- (display (prompt (* 2 (control f 3))))- (newline))--(write-string "should be 30\t\t")-(sandbox- (display (prompt (* 2 (control f (* 5 (f 3))))))- (newline))--(write-string "should be 12\t\t")-(sandbox- (display (prompt (* 2 (control f (f (f 3))))))- (newline))--(write-string "should be 6\t\t")-(sandbox- (display ((prompt (* 2 (control f f))) 3))- (newline))--(write-string "should be 35\t\t")-(sandbox- (display (prompt (* 5- (prompt (* 2- (control f2 (* 3 (control f3 7))))))))- (newline))--; haskeem quasi-fails this: because it's a (lambda () ...), it escapes,-; and so at the end there's an uncaught exception which however carries-; along the correct value as its payload. So I think haskeem would handle-; this correctly if there were an implicit top-level catcher--(write-string "should be 7\t\t")-(sandbox- (display (prompt (* 5 (- (prompt (* 2- (control f2 (lambda ()- (* 3 (control f3 7))))))))))- (newline))--(write-string "should be 21\t\t")-(sandbox- (display (prompt (* 5- ((lambda (x) (control f1 x))- (* 3 (control f2 (* 2 (f2 7))))))))- (newline))--(write-string "prompt0/control0 examples\n")-(write-string "should be 3\t\t")-(sandbox- (display (prompt0 (* 2 (control0 f 3))))- (newline))--(write-string "should be 30\t\t")-(sandbox- (display (prompt0 (* 2 (control0 f (* 5 (f 3))))))- (newline))--(write-string "should be 12\t\t")-(sandbox- (display (prompt0 (* 2 (control0 f (f (f 3))))))- (newline))--(write-string "should be 6\t\t")-(sandbox- (display ((prompt0 (* 2 (control0 f f))) 3))- (newline))+(write-string "prompt/control examples (withdrawn for now)\n")+;; (write-string "should be 3\t\t")+;; (sandbox+;; (display (prompt (* 2 (control f 3))))+;; (newline))+;; +;; (write-string "should be 30\t\t")+;; (sandbox+;; (display (prompt (* 2 (control f (* 5 (f 3))))))+;; (newline))+;; +;; (write-string "should be 12\t\t")+;; (sandbox+;; (display (prompt (* 2 (control f (f (f 3))))))+;; (newline))+;; +;; (write-string "should be 6\t\t")+;; (sandbox+;; (display ((prompt (* 2 (control f f))) 3))+;; (newline))+;; +;; (write-string "should be 35\t\t")+;; (sandbox+;; (display (prompt (* 5+;; (prompt (* 2+;; (control f2 (* 3 (control f3 7))))))))+;; (newline)) -(write-string "should be 7\t\t")-(sandbox- (display (prompt0 (* 5- (prompt0 (* 2- (control0 f2 (* 3 (control0 f3 7))))))))- (newline))+;; (write-string "should be 7\t\t")+;; (sandbox+;; (display (prompt (* 5 (+;; (prompt (* 2+;; (control f2 (lambda ()+;; (* 3 (control f3 7))))))))))+;; (newline))+;; +;; (write-string "should be 21\t\t")+;; (sandbox+;; (display (prompt (* 5+;; ((lambda (x) (control f1 x))+;; (* 3 (control f2 (* 2 (f2 7))))))))+;; (newline)) -(write-string "should be 7\t\t")-(sandbox- (display (prompt0 (* 5 (- (prompt0 (* 2- (control0 f2 (lambda ()- (* 3 (control0 f3 7))))))))))- (newline))+(write-string "prompt0/control0 examples (withdrawn for now)\n")+;; (write-string "should be 3\t\t")+;; (sandbox+;; (display (prompt0 (* 2 (control0 f 3))))+;; (newline))+;; +;; (write-string "should be 30\t\t")+;; (sandbox+;; (display (prompt0 (* 2 (control0 f (* 5 (f 3))))))+;; (newline))+;; +;; (write-string "should be 12\t\t")+;; (sandbox+;; (display (prompt0 (* 2 (control0 f (f (f 3))))))+;; (newline))+;; +;; (write-string "should be 6\t\t")+;; (sandbox+;; (display ((prompt0 (* 2 (control0 f f))) 3))+;; (newline))+;; +;; (write-string "should be 7\t\t")+;; (sandbox+;; (display (prompt0 (* 5+;; (prompt0 (* 2+;; (control0 f2 (* 3 (control0 f3 7))))))))+;; (newline))+;; +;; (write-string "should be 7\t\t")+;; (sandbox+;; (display (prompt0 (* 5 (+;; (prompt0 (* 2+;; (control0 f2 (lambda ()+;; (* 3 (control0 f3 7))))))))))+;; (newline)) ; There's something odd with this test: in mzscheme, it prints the ; result 21, then the whole rest of the test vanishes; apparently@@ -478,12 +471,12 @@ ; world just vanishes. If I surround this with a (reset ...), the ; test continues, but this doesn't print anything. Hmmm! -(write-string "should be 21\t\t")-(sandbox- (display (prompt0 (* 5- ((lambda (x) (control0 f1 x))- (* 3 (control0 f2 (* 2 (f2 7))))))))- (newline))+;; (write-string "should be 21\t\t")+;; (sandbox+;; (display (prompt0 (* 5+;; ((lambda (x) (control0 f1 x))+;; (* 3 (control0 f2 (* 2 (f2 7))))))))+;; (newline)) (write-string "reset/shift examples\n") (write-string "should be 3\t\t")@@ -528,50 +521,50 @@ (* 3 (shift f2 (* 2 (f2 7)))))))) (newline)) -(write-string "reset0/shift0 examples\n")-(write-string "should be 3\t\t")-(sandbox- (display (reset0 (* 2 (shift0 f 3))))- (newline))--(write-string "should be 30\t\t")-(sandbox- (display (reset0 (* 2 (shift0 f (* 5 (f 3))))))- (newline))--(write-string "should be 12\t\t")-(sandbox- (display (reset0 (* 2 (shift0 f (f (f 3))))))- (newline))--(write-string "should be 6\t\t")-(sandbox- (display ((reset0 (* 2 (shift0 f f))) 3))- (newline))--(write-string "should be 7\t\t")-(sandbox- (display (reset0 (* 5- (reset0 (* 2- (shift0 f2 (* 3 (shift0 f3 7))))))))- (newline))--(write-string "should be 7\t\t")-(sandbox- (display (reset0 (* 5 (- (reset0 (* 2- (shift0 f2 (lambda ()- (* 3 (shift0 f3 7))))))))))- (newline))--(write-string "should be 42\t\t")-(sandbox- (display (reset0 (* 5- ((lambda (x) (shift0 f1 x))- (* 3 (shift0 f2 (* 2 (f2 7))))))))- (newline))+(write-string "reset0/shift0 examples (withdrawn for now)\n")+;; (write-string "should be 3\t\t")+;; (sandbox+;; (display (reset0 (* 2 (shift0 f 3))))+;; (newline))+;; +;; (write-string "should be 30\t\t")+;; (sandbox+;; (display (reset0 (* 2 (shift0 f (* 5 (f 3))))))+;; (newline))+;; +;; (write-string "should be 12\t\t")+;; (sandbox+;; (display (reset0 (* 2 (shift0 f (f (f 3))))))+;; (newline))+;; +;; (write-string "should be 6\t\t")+;; (sandbox+;; (display ((reset0 (* 2 (shift0 f f))) 3))+;; (newline))+;; +;; (write-string "should be 7\t\t")+;; (sandbox+;; (display (reset0 (* 5+;; (reset0 (* 2+;; (shift0 f2 (* 3 (shift0 f3 7))))))))+;; (newline))+;; +;; (write-string "should be 7\t\t")+;; (sandbox+;; (display (reset0 (* 5 (+;; (reset0 (* 2+;; (shift0 f2 (lambda ()+;; (* 3 (shift0 f3 7))))))))))+;; (newline))+;; +;; (write-string "should be 42\t\t")+;; (sandbox+;; (display (reset0 (* 5+;; ((lambda (x) (shift0 f1 x))+;; (* 3 (shift0 f2 (* 2 (f2 7))))))))+;; (newline)) -(write-string "r something actually useful! a small table of factorials\n")+(write-string "something actually useful! a small table of factorials\n") ; Eventually we want to be able to use code like this: @@ -635,8 +628,8 @@ (doit7 #t) ; (1 3 5 2 4) -- mzscheme sez (1 3 2 4) (write-string- "syntax error coming up! should be an error... this'll kill mzscheme\n")+ "syntax error coming up! should be an error... this'll kill mzscheme,\n")+(write-string+ "but haskeem should catch the exception raised by the syntax error\n") (sandbox (display (+ 1 (reset (+ 2 (shift (+ k 1) 3))))))-(write-string- "haskeem should have caught the exception raised by the syntax error\n")
haskeem.cabal view
@@ -1,5 +1,5 @@ Name: haskeem-Version: 0.7.12+Version: 0.7.16 Homepage: http://www.korgwal.com/haskeem/ Author: Uwe Hollerbach <uh@alumni.caltech.edu> Maintainer: Uwe Hollerbach <uh@alumni.caltech.edu>
haskeem.hs view
@@ -18,7 +18,7 @@ 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.43 2009-08-08 05:09:00 uwe Exp $ -}+$Id: haskeem.hs,v 1.49 2010-01-05 05:43:27 uwe Exp $ -} module Main where import Prelude@@ -42,7 +42,7 @@ -- haskeem version version :: String-version = "0.7.12"+version = "0.7.16" -- a variable under which any command-line arguments to a script are -- made available; empty for interactive mode@@ -61,8 +61,9 @@ evalAndPrint :: Env -> Bool -> String -> InputT IO () evalAndPrint env pflag expr =- do ret <- liftIO (runErrorT (liftThrows (readExpr (dropWhile isSpace expr))- >>= evalPP env >>= evalLisp env [] 0))+ do let eenv = EEnv env [] [] 0+ ret <- liftIO (runErrorT (liftThrows (readExpr (dropWhile isSpace expr))+ >>= evalPP eenv >>= evalLisp eenv)) case ret of Left err -> outputStrLn (show err) Right val -> if pflag then outputStrLn (show val) else outputStr ""@@ -101,7 +102,7 @@ -- the actual REPL, combined with tasty haskeline goodness catcher :: CE.Exception -> InputT IO ()-catcher e = outputStrLn "Interrupt!"+catcher _ = outputStrLn "Interrupt!" doREPL :: Env -> InputT IO () doREPL env =@@ -132,7 +133,7 @@ do env <- setupBindings (map String (drop 1 args)) False runInputT defaultSettings (runInit env >>- evalAndPrint env False ("(load \"" ++ (args !! 0) ++ "\")"))+ evalAndPrint env False ("(load \"" ++ head args ++ "\")")) main :: IO () main =
haskeem_readline.hs view
@@ -42,7 +42,7 @@ -- haskeem version version :: String-version = "0.7.12"+version = "0.7.16" -- a variable under which any command-line arguments to a script are -- made available; empty for interactive mode@@ -61,11 +61,12 @@ evalAndPrint :: Env -> Bool -> String -> IO () evalAndPrint env pflag expr =- do ret <- runErrorT (liftThrows (readExpr (dropWhile isSpace expr))- >>= evalPP env >>= evalLisp env [] 0)+ do let eenv = EEnv env [] [] 0+ ret <- runErrorT (liftThrows (readExpr (dropWhile isSpace expr))+ >>= evalPP eenv >>= evalLisp eenv) case ret of Left err -> hPutStrLn stderr (show err)- Right val -> if pflag then putStrLn (show val) else putStr ""+ Right val -> if pflag then print val else putStr "" -- if the environment variable HASKEEM_INIT is set, try to load that file @@ -102,7 +103,7 @@ readline prompt = do putStr prompt hFlush stdout- ret <- CE.try (getLine)+ ret <- CE.try getLine case ret of Left err -> do hPutStrLn stderr "g'bye!" exitWith (ExitFailure 1)@@ -116,7 +117,7 @@ data MyInterrupt = MyInt deriving Typeable catcher :: MyInterrupt -> IO ()-catcher e = hPutStrLn stderr "Interrupt!"+catcher _ = hPutStrLn stderr "Interrupt!" doREPL :: Env -> IO () doREPL env =@@ -128,7 +129,7 @@ then doREPL env else do addHistory line catchDyn (evalAndPrint env True line)- (\e -> catcher e)+ catcher doREPL env where isBlank [] = True isBlank _ = False@@ -153,7 +154,7 @@ runOne args = do env <- setupBindings (map String (drop 1 args)) False runInit env- evalAndPrint env False ("(load \"" ++ (args !! 0) ++ "\")")+ evalAndPrint env False ("(load \"" ++ head args ++ "\")") main = do args <- getArgs
selftest.scm view
@@ -15,7 +15,7 @@ ; 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.46 2009-07-19 02:36:21 uwe Exp $+; $Id: selftest.scm,v 1.48 2010-01-18 05:15:29 uwe Exp $ (define start (epochtime)) @@ -881,6 +881,24 @@ (chk-run lst '(list-unref lst 100)) (chk-run -24 '(last lst)) +(chk-run '((4 2 6) (1 3 4 2 7 5 5 4))+ '(span even? '(4 2 6 1 3 4 2 7 5 5 4)))+(chk-run '((4 2 6 8) (3 4 2 7 5 5 4))+ '(span even? '(4 2 6 8 3 4 2 7 5 5 4)))+(chk-run '((4) (1 2 6 8 3 4 2 7 5 5 4))+ '(span even? '(4 1 2 6 8 3 4 2 7 5 5 4)))+(chk-run '(() (1 2 6 8 3 4 2 7 5 5 4))+ '(span even? '(1 2 6 8 3 4 2 7 5 5 4)))+(chk-run '((2 4 6 8 4 6 2 10) ())+ '(span even? '(2 4 6 8 4 6 2 10)))+(chk-run '(() ()) '(span even? '()))++(chk-run '((#\M) (#\i) (#\s #\s) (#\i) (#\s #\s) (#\i) (#\p #\p) (#\i))+ '(list-group-by eqv? (string->char "Mississippi")))+(chk-run '((4) (1) (2 6 8) (3) (4 2) (7 5 5) (4))+ '(list-group-by (lambda (a b) (eqv? (even? a) (even? b)))+ '(4 1 2 6 8 3 4 2 7 5 5 4)))+ (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))))@@ -2407,7 +2425,8 @@ (catch-exceptions (chk-query "test directory" '(get-current-directory))) (catch-exceptions (chk-run #t '(set-current-directory ".."))) (catch-exceptions (chk-run #t '(remove-directory test-dir1)))- (run-command (string-join-by " " "/bin/rm -rf" test-dir1)))+ (catch-exceptions+ (run-command (string-join-by " " "/bin/rm -rf" test-dir1)))) (if (directory-exists? test-dir1) (write-string "\nSkipping file and directory I/O tests,\n"
stdlib.scm view
@@ -18,7 +18,7 @@ ; 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.43 2009-08-06 05:05:15 uwe Exp $+; $Id: stdlib.scm,v 1.44 2010-01-18 05:15:29 uwe Exp $ ; The haskeem standard library @@ -259,6 +259,30 @@ (cond ((null? lst) #f) ((proc (car lst)) (car lst)) (else (find proc (cdr lst)))))++; This returns a partition of the input list: the longest prefix of the+; input list for which (pred val) returns #t, and the remainder of the list.++(define (span pred lst)+ (cond ((null? lst) (list () ()))+ ((pred (car lst))+ (let ((st (span pred (cdr lst))))+ (list (cons (car lst) (car st)) (cadr st))))+ (else (list () lst))))++; This turns a list into a list-of-lists, where each sub-list is a group+; of elements which compare equal according to the comparison function:+; for example+; (list-group-by eqv? (string->char "Mississippi"))+; returns+; ((#\M) (#\i) (#\s #\s) (#\i) (#\s #\s) (#\i) (#\p #\p) (#\i))+; with equal characters grouped together.++(define (list-group-by cmp lst)+ (if (null? lst)+ ()+ (let ((st (span (curry cmp (car lst)) (cdr lst))))+ (cons (cons (car lst) (car st)) (list-group-by cmp (cadr st)))))) ; 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: