haskeem 0.7.9 → 0.7.12
raw patch · 13 files changed
+1361/−514 lines, 13 files
Files
- Environment.hs +2/−3
- Evaluator.hs +254/−153
- Library.hs +11/−5
- LispData.hs +8/−5
- Parser.hs +2/−3
- WriteNumber.hs +2/−3
- callcc.scm +39/−1
- delTEST.scm +642/−0
- deltest.scm +370/−310
- haskeem.cabal +6/−6
- haskeem.hs +4/−5
- haskeem_readline.hs +12/−11
- stdlib.scm +9/−9
Environment.hs view
@@ -1,8 +1,7 @@ {- Copyright 2008 Uwe Hollerbach <uh@alumni.caltech.edu> Portions of this were derived from Jonathan Tang's haskell tutorial "Write yourself a scheme in 48 hours" and are thus-Copyright Jonathan Tang-(but I can't easily tell anymore who originally wrote what)+Copyright Jonathan Tang (but there isn't much of his stuff left). This file is part of haskeem. haskeem is free software; you can redistribute it and/or modify@@ -19,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: environment.hs,v 1.11 2009-06-27 20:31:51 uwe Exp $ -}+$Id: environment.hs,v 1.12 2009-08-06 05:05:15 uwe Exp $ -} module Environment (isBound, getVar, setVar, defineVar, bindVars, dumpEnv) where
Evaluator.hs view
@@ -1,8 +1,7 @@ {- Copyright 2008 Uwe Hollerbach <uh@alumni.caltech.edu> Portions of this were derived from Jonathan Tang's haskell tutorial "Write yourself a scheme in 48 hours" and are thus-Copyright Jonathan Tang-(but I can't easily tell anymore who originally wrote what)+Copyright Jonathan Tang (but there isn't much of his stuff left). This file is part of haskeem. haskeem is free software; you can redistribute it and/or modify@@ -19,9 +18,9 @@ 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.35 2009-07-04 07:47:22 uwe Exp $ -}+$Id: evaluator.hs,v 1.40 2009-08-08 05:08:59 uwe Exp $ -} -module Evaluator (evalLisp) where+module Evaluator (evalLisp, evalPP) where import Prelude import IO import Control.Exception as CE()@@ -102,8 +101,9 @@ -- omnipotent thing that does all the work doApply :: Bool -> String -> [String] -> (Maybe String) -> [LispVal]- -> Env -> Integer -> [LispVal] -> IOThrowsError LispVal-doApply trace name params varargs body closure ql args =+ -> Env -> [[LispVal]] -> Integer -> [LispVal]+ -> IOThrowsError LispVal+doApply trace name params varargs body closure dcs ql args = if num params /= num args && varargs == Nothing then errNumArgs (show body) (num params) args else prtTrace >>@@ -111,7 +111,7 @@ bindVarArgs varargs >>= evalBody where remainingArgs = drop (length params) args num = toInteger . length- evalBody env = mapML (evalLisp env ql) body+ evalBody env = mapML (evalLisp env dcs ql) body bindVarArgs arg env = case arg of Just argName ->@@ -123,14 +123,15 @@ return True else return False -apply :: Integer -> LispVal -> [LispVal] -> IOThrowsError LispVal-apply _ (Prim func) args = liftThrows (func args)-apply _ (IOPrim func) args = func args-apply ql (Func params varargs body closure Nothing _) args =- doApply False "" params varargs body closure ql args-apply ql (Func params varargs body closure (Just name) _) args =- doApply True name params varargs body closure ql args-apply _ func _ = throwError (NotFunction "apply got non-function" func)+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) makeFunc varargs env params body = return (Func (map show params) varargs body env Nothing False)@@ -147,7 +148,8 @@ "guard", "if", "lambda", "let", "let*", "letrec", "letrec*", "load", "or", "quasiquote", "quote", "set!", "unquote", "unquote-splicing", "vector-fill!",- "vector-set!", "trace", "dump-bindings"]+ "vector-set!", "ext cont", "int cont",+ "trace", "dump-bindings"] isSpecialForm (Symbol s) = seek s specialForms where seek _ [] = False@@ -214,30 +216,30 @@ -- or an unquote-splicing at the right quote level; these it evaluates via -- evalLisp and patches into the tree -evalQQ :: Env -> Integer -> LispVal -> IOThrowsError LispVal+evalQQ :: Env -> [[LispVal]] -> Integer -> LispVal -> IOThrowsError LispVal -- "quasiquote", "unquote", and "unquote-splicing" might get evaluated, -- depending on quote level -evalQQ env ql (List [Symbol "quasiquote", arg]) =- do val <- evalQQ env (ql + 1) arg >>= liftSUnq+evalQQ env dcs ql (List [Symbol "quasiquote", arg]) =+ do val <- evalQQ env dcs (ql + 1) arg >>= liftSUnq return (List [Symbol "quasiquote", val]) -evalQQ env ql (List (Symbol "unquote" : args)) =+evalQQ env dcs ql (List (Symbol "unquote" : args)) = if ql == 1- then do vals <- mapM (evalLisp env 0) args+ then do vals <- mapM (evalLisp env dcs 0) args return (List ((Symbol unq):vals))- else do vals <- mapM (evalQQ env (ql - 1)) args+ else do vals <- mapM (evalQQ env dcs (ql - 1)) args return (List ((Symbol "unquote") : (liftLUnq vals))) -evalQQ env ql (List (Symbol "unquote-splicing" : args)) =+evalQQ env dcs ql (List (Symbol "unquote-splicing" : args)) = if ql == 1- then do vals <- mapM (evalLisp env 0) args+ 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 (ql - 1)) args+ else do vals <- mapM (evalQQ env dcs (ql - 1)) args return (List ((Symbol "unquote-splicing") : (liftLUnq vals))) where isLL [] = True isLL ((List _):ls) = isLL ls@@ -247,12 +249,12 @@ -- lists, dotted-lists, and vectors get traversed -evalQQ env ql (List con) =- mapM (evalQQ env ql) con >>= return . List . liftLUnq+evalQQ env dcs ql (List con) =+ mapM (evalQQ env dcs ql) con >>= return . List . liftLUnq -evalQQ env ql (DottedList con cab) =- do vals <- mapM (evalQQ env ql) con- vcab <- evalQQ env ql cab >>= liftSUnq+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 if isList vcab then return (List (head ++ (getList vcab)))@@ -260,8 +262,8 @@ then return (DottedList (head ++ (getDLh vcab)) (getDLt vcab)) else return (DottedList head vcab) -evalQQ env ql (Vector _ con) =- do vals <- mapM (evalQQ env ql) (remkey (DIM.toAscList con))+evalQQ env dcs ql (Vector _ con) =+ do vals <- mapM (evalQQ env dcs ql) (remkey (DIM.toAscList con)) let new = DIM.fromAscList (addkey 0 (liftLUnq vals)) return (Vector (toInteger (DIM.size new)) new) where remkey [] = []@@ -271,22 +273,69 @@ -- 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.++-- TODO: check shift etc 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 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 env (List args) = mapM (evalPP env) args >>= return . List++-- everything else gets returned unchanged++evalPP env val = return val+ -- This is the main evaluator -evalLisp :: Env -> Integer -> LispVal -> IOThrowsError LispVal+evalLisp :: Env -> [[LispVal]] -> Integer -> LispVal -> IOThrowsError LispVal -- various simple things which evaluate to themselves -evalLisp _ _ val@(String _) = return val-evalLisp _ _ val@(IntNumber _) = return val-evalLisp _ _ val@(RatNumber _) = return val-evalLisp _ _ val@(FltNumber _) = return val-evalLisp _ _ val@(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 env _ _ (Symbol id) = getVar env id -- Special forms must go here, before the generic (function : args) stuff @@ -296,12 +345,12 @@ -- convenient to have it here; otherwise, we have to do all sorts of -- twisting to make it all work. -evalLisp env ql (List (Symbol "apply" : function : args)) =- do func <- evalLisp env ql function- argVals <- mapM (evalLisp env ql) args- appp ql (func:argVals)- where appp ql [func, List args] = apply ql func args- appp ql (func : args) = apply ql func args+evalLisp env dcs ql (List (Symbol "apply" : function : args)) =+ do func <- evalLisp env dcs ql function+ argVals <- mapM (evalLisp env dcs ql) args+ appp (func:argVals)+ where appp [func, List args] = apply dcs ql func args+ appp (func : args) = apply dcs ql func args -- TODO: this is not a special form according to R6RS; the only reason -- I put it here is because evalLisp wants an environment, and that's@@ -314,8 +363,10 @@ -- move this into the libraries... I'd just have to provide access to -- the (or a) top-level environment. -evalLisp env ql (List (Symbol "eval" : args)) =- mapM (evalLisp env ql) args >>= mapML (evalLisp env ql)+evalLisp env dcs ql (List (Symbol "eval" : args)) =+ mapM (evalPP env) args >>=+ mapM (evalLisp env dcs ql) >>=+ mapML (evalLisp env dcs ql) -- 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@@ -324,50 +375,50 @@ -- wants to (or should be able to) call (load) from within some -- function and modify the environment seen within that function. -evalLisp env ql (List [Symbol "load", String filename]) =- loadFile filename >>= mapML (evalLisp env ql)-evalLisp env ql (List [Symbol "load", arg]) =- do fname <- evalLisp env ql arg+evalLisp env dcs ql (List [Symbol "load", arg]) =+ do fname <- evalLisp env dcs ql arg if isStr fname- then loadFile (getStr fname) >>= mapML (evalLisp env ql)+ then loadFile (getStr fname) >>=+ mapM (evalPP env) >>=+ mapML (evalLisp env dcs ql) else throwError (Default ("bad load form: " ++ (show fname) ++ " is not a string")) -evalLisp env ql (List (Symbol "begin" : args)) =- mapML (evalLisp env ql) args+evalLisp env dcs ql (List (Symbol "begin" : args)) =+ mapML (evalLisp env dcs ql) args -evalLisp _ _ (List [Symbol "quote", val]) = return val+evalLisp _ _ _ (List [Symbol "quote", val]) = return val -evalLisp env ql (List [Symbol "quasiquote", val]) =- evalQQ env (ql + 1) val >>= liftSUnq+evalLisp env dcs ql (List [Symbol "quasiquote", val]) =+ evalQQ env dcs (ql + 1) val >>= liftSUnq -evalLisp _ _ (List (Symbol "unquote" : args)) =+evalLisp _ _ _ (List (Symbol "unquote" : args)) = throwError (Default ("naked unquote form: " ++ (show args))) -evalLisp _ _ (List (Symbol "unquote-splicing" : args)) =+evalLisp _ _ _ (List (Symbol "unquote-splicing" : args)) = throwError (Default ("naked unquote-splicing form: " ++ (show args))) -evalLisp env ql (List [Symbol "set!", Symbol var, val]) =- evalLisp env ql val >>= setVar env var+evalLisp env dcs ql (List [Symbol "set!", Symbol var, val]) =+ evalLisp env dcs ql val >>= setVar env var -evalLisp env ql (List [Symbol "vector-set!", Symbol var, indx, obj]) =- do vec <- evalLisp env ql (Symbol var)+evalLisp env dcs ql (List [Symbol "vector-set!", Symbol var, indx, obj]) =+ do vec <- evalLisp env dcs ql (Symbol var) if isVec vec- then do lk <- evalLisp env ql indx+ then do lk <- evalLisp env dcs ql indx let l = getVecL vec k = getInt lk if ((isInt lk) && k >= 0 && k < l)- then do val <- evalLisp env ql obj+ then do val <- evalLisp env dcs ql obj setVar env 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")) -evalLisp env ql (List [Symbol "vector-fill!", Symbol var, obj]) =- do vec <- evalLisp env ql (Symbol var)+evalLisp env dcs ql (List [Symbol "vector-fill!", Symbol var, obj]) =+ do vec <- evalLisp env dcs ql (Symbol var) if isVec vec- then do val <- evalLisp env ql obj+ then do val <- evalLisp env dcs ql obj let n = getVecL vec setVar env var (Vector n (DIM.fromAscList (addkey val (fromInteger n))))@@ -376,10 +427,10 @@ where addkey _ 0 = [] addkey v n = ((n-1), v):(addkey v (n-1)) -evalLisp env ql (List [Symbol "vector-resize!", Symbol var, obj]) =- do vec <- evalLisp env ql (Symbol var)+evalLisp env dcs ql (List [Symbol "vector-resize!", Symbol var, obj]) =+ do vec <- evalLisp env dcs ql (Symbol var) if isVec vec- then do lk <- evalLisp env ql obj+ then do lk <- evalLisp env dcs ql obj let l = getVecL vec k = getInt lk if (isInt lk) && (k > 0)@@ -400,75 +451,78 @@ then vec else add (DIM.insert (fromInteger l) lispFalse vec) h (l + 1) -evalLisp env ql (List [Symbol "define", Symbol var, val]) =+evalLisp env dcs ql (List [Symbol "define", Symbol var, val]) = do defineVar env var lispFalse- evalLisp env ql val >>= setVar env var-evalLisp env _ (List [Symbol "define", Symbol var]) =+ evalLisp env dcs ql val >>= setVar env var+evalLisp env _ _ (List [Symbol "define", Symbol var]) = defineVar env var lispFalse-evalLisp env _ (List (Symbol "define" : List (Symbol var : params) : body)) =+evalLisp env dcs _+ (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 _ (List (Symbol "define" :- DottedList (Symbol var : params) varargs : body)) =+evalLisp env dcs _ (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 _ (List (Symbol "defmacro" : List (Symbol var : params) : body)) =+evalLisp env dcs _+ (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 _ (List (Symbol "defmacro" :- DottedList (Symbol var : params) varargs : body)) =+evalLisp env dcs _ (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 _ (List (Symbol "lambda" : List params : body)) =+evalLisp env dcs _ (List (Symbol "lambda" : List params : body)) = if paramsCheck params then makeNormalFunc env params body else errBadForm "lambda" params-evalLisp env _ (List (Symbol "lambda" : DottedList params varargs : body)) =+evalLisp env dcs _+ (List (Symbol "lambda" : DottedList params varargs : body)) = if paramsCheck (params ++ [varargs]) then makeVarargsFunc varargs env params body else errBadForm "lambda" [DottedList params varargs]-evalLisp env _ (List (Symbol "lambda" : varargs@(Symbol _) : body)) =+evalLisp env dcs _ (List (Symbol "lambda" : varargs@(Symbol _) : body)) = makeVarargsFunc varargs env [] body -evalLisp env ql (List [Symbol "if", pred, tcase, fcase]) =- do result <- evalLisp env ql pred+evalLisp env dcs ql (List [Symbol "if", pred, tcase, fcase]) =+ do result <- evalLisp env dcs ql pred case result of- Boolean False -> evalLisp env ql fcase- _ -> evalLisp env ql tcase-evalLisp env ql (List [Symbol "if", pred, tcase]) =- do result <- evalLisp env ql pred+ 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 case result of Boolean False -> return lispFalse- _ -> evalLisp env ql tcase+ _ -> evalLisp env dcs ql tcase -evalLisp env ql (List (Symbol "and" : args)) = eva env args lispTrue+evalLisp env dcs ql (List (Symbol "and" : args)) = eva env args lispTrue where eva _ [] ret = return ret eva env (t:ts) _ =- do result <- evalLisp env ql t+ do result <- evalLisp env dcs ql t case result of Boolean False -> return lispFalse _ -> eva env ts result -evalLisp env ql (List (Symbol "or" : args)) = evo env args lispFalse+evalLisp env dcs ql (List (Symbol "or" : args)) = evo env args lispFalse where evo _ [] ret = return ret evo env (t:ts) _ =- do result <- evalLisp env ql t+ do result <- evalLisp env dcs ql t case result of Boolean False -> evo env ts result _ -> return result -evalLisp _ _ (List [Symbol "cond"]) = return lispFalse-evalLisp env ql (List (Symbol "cond" : args)) =+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@@ -476,70 +530,71 @@ 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 ql) args+ do ret <- mapML (evalLisp env dcs ql) args return (True, ret) evc_clause env (List (pred : args)) =- do tst <- evalLisp env ql pred+ do tst <- evalLisp env dcs ql pred case tst of Boolean False -> return (False, lispFalse) _ -> do ret <- if isArrow args then evcArrow env args tst- else mapML (evalLisp env ql) args+ else mapML (evalLisp env dcs ql) args return (True, ret) evc_clause _ _ = return (False, lispFalse) isArrow [Symbol "=>", _] = True isArrow _ = False evcArrow env [Symbol "=>", proc] val =- evalLisp env ql proc >>= (flip (apply ql)) [val]+ evalLisp env dcs ql proc >>= (flip (apply dcs ql)) [val] -evalLisp env ql (List (Symbol "let" : List params : body)) =+evalLisp env dcs ql (List (Symbol "let" : List params : body)) = if letCheck True params then do func <- makeNormalFunc env (map exn params) body- argVals <- mapM (evalLisp env ql) (map exv params)- apply ql func argVals+ argVals <- mapM (evalLisp env dcs ql) (map exv params)+ apply dcs ql func argVals else errBadForm "let" params where exn (List [Symbol var, _]) = Symbol var exv (List [Symbol _, val]) = val -evalLisp env ql (List (Symbol "let" : Symbol lname : List params : body)) =+evalLisp env dcs ql+ (List (Symbol "let" : Symbol lname : List params : body)) = if letCheck True params then do envn <- liftIO (bindVars env [(lname, lispFalse)]) func <- makeNormalFunc envn (map exn params) body setVar envn lname func- argVals <- mapM (evalLisp env ql) (map exv params)- apply ql func argVals+ argVals <- mapM (evalLisp env dcs ql) (map exv params)+ apply dcs ql func argVals else errBadForm "named-let" params where exn (List [Symbol var, _]) = Symbol var exv (List [Symbol _, val]) = val -evalLisp env ql (List (Symbol "let*" : List params : body)) =+evalLisp env dcs ql (List (Symbol "let*" : List params : body)) = if letCheck False params then dols params body env else errBadForm "let*" params- where dols [] body env = mapML (evalLisp env ql) body+ where dols [] body env = mapML (evalLisp env dcs ql) body dols (p:ps) body env =- do val <- evalLisp env ql (exv p)+ do val <- evalLisp env dcs ql (exv p) (liftIO (bindVars env [(exn p, val)])) >>= (dols ps body) exn (List [Symbol var, _]) = var exv (List [Symbol _, val]) = val -evalLisp env ql (List (Symbol "letrec" : List params : body)) =+evalLisp env dcs ql (List (Symbol "letrec" : List params : body)) = if letCheck True params then dolr params body env else errBadForm "letrec" params where dolr params body env = do let varn = map exn params envn <- liftIO (bindVars env varn)- varv <- mapM (evalLisp envn ql) (map exv params)+ varv <- mapM (evalLisp envn dcs ql) (map exv params) mapM (doSet envn) (repl varn varv) >>- mapML (evalLisp envn ql) body+ mapML (evalLisp envn dcs ql) body exn (List [Symbol var, _]) = (var, lispFalse) exv (List [Symbol _, val]) = val repl [] [] = [] repl ((n, lispFalse):ns) (v:vs) = (n, v):(repl ns vs) doSet env (n,v) = setVar env n v -evalLisp env ql (List (Symbol "letrec*" : List params : body)) =+evalLisp env dcs ql (List (Symbol "letrec*" : List params : body)) = if letCheck False params then dolr params body env else errBadForm "letrec*" params@@ -547,16 +602,16 @@ do let varn = map exn params envn <- liftIO (bindVars env varn) mapM (evSet envn) params >>- mapML (evalLisp envn ql) body+ mapML (evalLisp envn dcs ql) body exn (List [Symbol var, _]) = (var, lispFalse) evSet env (List [Symbol var, val]) =- evalLisp env ql val >>= setVar env var+ evalLisp env dcs ql val >>= setVar env var -evalLisp _ _ (List [Symbol "case"]) = return lispFalse-evalLisp env ql (List (Symbol "case" : key : args)) =+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 ql key >>= evc env args+ else evalLisp env dcs ql key >>= evc env args where isNull [] = True isNull _ = False isLL (List (List _ : _)) = True@@ -566,11 +621,11 @@ evc env (cl:cls) key = do (tst,val) <- evc_clause env cl key if tst then return val else evc env cls key evc_clause env (List (Symbol "else" : args)) _ =- do ret <- mapML (evalLisp env ql) args+ do ret <- mapML (evalLisp env dcs ql) args return (True, ret) evc_clause env (List (List vals : args)) key = if valMatch key vals- then do ret <- mapML (evalLisp env ql) args+ then do ret <- mapML (evalLisp env dcs ql) args return (True, ret) else return (False, lispFalse) evc_clause _ _ _ = return (False, lispFalse)@@ -579,10 +634,11 @@ else (valMatch key vs) valMatch _ [] = False -evalLisp env ql (List (Symbol "guard" : List (Symbol var : clauses) : body)) =+evalLisp env dcs ql+ (List (Symbol "guard" : List (Symbol var : clauses) : body)) = if foldl (&&) True (map isList clauses) == False then errTypeMismatch "guard" "error-clauses" (String (show clauses))- else catchError (mapML (evalLisp env ql) body)+ else catchError (mapML (evalLisp env dcs ql) body) (\err -> do let errval = unpackErr err liftIO (bindVars env [(var, errval)]) >>= evc err clauses)@@ -592,21 +648,21 @@ 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 ql) args+ do ret <- mapML (evalLisp env dcs ql) args return (True, ret) evc_clause env (List (pred : args)) =- do tst <- evalLisp env ql pred+ do tst <- evalLisp env dcs ql pred case tst of Boolean False -> return (False, lispFalse) _ -> do ret <- if isArrow args then evcArrow env args tst- else mapML (evalLisp env ql) args+ else mapML (evalLisp env dcs ql) args return (True, ret) evc_clause _ _ = return (False, lispFalse) isArrow [Symbol "=>", _] = True isArrow _ = False evcArrow env [Symbol "=>", proc] val =- evalLisp env ql proc >>= (flip (apply ql)) [val]+ evalLisp env dcs ql proc >>= (flip (apply dcs ql)) [val] -- This creates an internal variable for each delay object where its value -- will be stored once it is forced. We avoid collisions with any symbols@@ -614,14 +670,14 @@ -- 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]) =+evalLisp env _ _ (List [Symbol "delay", val]) = do dval <- getVar env delayCounter let count = getInt dval do setVar env delayCounter (IntNumber (count + 1)) return (Delay val env (" delay." ++ (show count))) -evalLisp envc ql (List [Symbol "force", val]) =- do vali <- evalLisp envc ql val+evalLisp envc dcs ql (List [Symbol "force", val]) =+ do vali <- evalLisp envc dcs ql val if isDelay vali then do let (env, tag) = getTag vali alreadyDef <- liftIO (isBound env tag)@@ -632,13 +688,13 @@ where isDelay (Delay _ _ _) = True isDelay _ = False getTag (Delay _ env tag) = (env, tag)- forceEval (Delay obj env _) = evalLisp env ql obj+ forceEval (Delay obj env _) = evalLisp env dcs ql obj -evalLisp env ql (List (Symbol "do" : List params : List test : body)) =+evalLisp env dcs ql (List (Symbol "do" : List params : List test : body)) = if doCheck params then do let names = map exn params steps = map exs params- inits <- mapM (evalLisp env ql) (map exi params)+ inits <- mapM (evalLisp env dcs ql) (map exi params) envn <- liftIO (bindVars env (zip names inits)) doloop envn names test steps else errBadForm "do" params@@ -650,23 +706,67 @@ exs (List [Symbol _, _, step]) = step doSet env (n,v) = setVar env n v doloop env names (test:rets) steps =- do tval <- evalLisp env ql test+ do tval <- evalLisp env dcs ql test if isTrue tval- then mapML (evalLisp env ql) rets- else do mapM (evalLisp env ql) body- svals <- mapM (evalLisp env ql) steps+ 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 -- 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 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))) +-- 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.++-- TODO: we may need to add individual ids to the DelCont... this is part+-- of delcont.scm, although I don't quite understand it++evalLisp env dcs ql (List ((Symbol "ext cont"):(Symbol id):args)) =+ catchError (mapML (evalLisp env (args:dcs) ql) args)+ (\val -> getVal val)+ 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)) =+ 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 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+ 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+ -- This is not an R6RS special form, but it is a haskeem one: it needs -- to be, because we don't want to evaluate the function name, and we -- do want to be able to do stuff in the current environment, so that@@ -680,11 +780,11 @@ -- 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 ql (List [Symbol "trace", Symbol var, sw]) =+evalLisp env dcs ql (List [Symbol "trace", Symbol var, sw]) = if isSpecialForm (Symbol var) then throwError (Default "can't trace special forms")- else do val <- evalLisp env ql (Symbol var)- swval <- evalLisp env ql sw+ else do val <- evalLisp env dcs ql (Symbol var)+ swval <- evalLisp env dcs ql sw if isPr val then throwError (Default "can't trace primitives") else if (isF val)@@ -713,9 +813,9 @@ -- to be, because we want the ability to show the current environment -- rather than just the top-level one -evalLisp env _ (List [Symbol "dump-bindings"]) = dumpEnv env stderr-evalLisp env ql (List [Symbol "dump-bindings", val]) =- do vali <- evalLisp env ql val+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 if isPort vali then dumpEnv env (getPort vali) else errBadForm "dump-bindings" [val]@@ -726,18 +826,19 @@ -- The generic (function : args) stuff; also macro expansion stuff -- For macro expansion, we evaluate once to get syntax back from the--- macro, that's the "evalLisp env ql function", but then we change+-- 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 ql (List (function : args)) =+evalLisp env dcs ql (List (function : args)) = if isSpecialForm function then throwError (BadSpecial "bad syntax for special form" function)- else do func <- evalLisp env ql function+ else do func <- evalLisp env dcs ql function if isM func- then apply ql (chEnv func env) args >>=+ then apply dcs ql (chEnv func env) args >>= prtTrace (isT func) >>=- evalLisp env ql- else mapM (evalLisp env ql) args >>= apply ql func+ evalPP env >>=+ evalLisp env dcs ql+ else mapM (evalLisp env dcs ql) args >>= apply dcs ql func where isM (Func _ _ _ _ _ mac) = mac isM _ = False isT (Func _ _ _ _ (Just _) _) = True@@ -749,5 +850,5 @@ then remark (" -> " ++ (show vals)) >> return vals else return vals -evalLisp _ _ badForm =+evalLisp _ _ _ badForm = throwError (BadSpecial "Unrecognized special form" badForm)
Library.hs view
@@ -1,8 +1,7 @@ {- Copyright 2008 Uwe Hollerbach <uh@alumni.caltech.edu> Portions of this were derived from Jonathan Tang's haskell tutorial "Write yourself a scheme in 48 hours" and are thus-Copyright Jonathan Tang-(but I can't easily tell anymore who originally wrote what)+Copyright Jonathan Tang (but there isn't much of his stuff left). This file is part of haskeem. haskeem is free software; you can redistribute it and/or modify@@ -19,9 +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.37 2009-07-27 02:01:04 uwe Exp $ -}+$Id: library.hs,v 1.39 2009-08-06 05:05:15 uwe Exp $ -} -module Library (primitiveBindings, delayCounter, symbolCounter, loadFile, eqv)+module Library (primitiveBindings, delayCounter, symbolCounter, contCounter,+ loadFile, eqv) where import Prelude import IO@@ -1643,6 +1643,8 @@ -- is stored in the environment. It contains spaces, so that it is -- impossible for the user to enter this as a valid symbol. Ditto -- for symbolCounter: this is for generating new internal symbols.+-- contCounter is for counting continuations operators; this could+-- equally well be done by symbolCounter. delayCounter :: String delayCounter = " delay "@@ -1650,9 +1652,13 @@ symbolCounter :: String symbolCounter = " symbol " +contCounter :: String+contCounter = " continuation "+ internals :: [(String, LispVal)] internals = [(delayCounter, (IntNumber 0)),- (symbolCounter, (IntNumber 0))]+ (symbolCounter, (IntNumber 0)),+ (contCounter, (IntNumber 0))] primitiveBindings :: IO Env primitiveBindings = newIORef [] >>=
LispData.hs view
@@ -1,8 +1,7 @@ {- Copyright 2008 Uwe Hollerbach <uh@alumni.caltech.edu> Portions of this were derived from Jonathan Tang's haskell tutorial "Write yourself a scheme in 48 hours" and are thus-Copyright Jonathan Tang-(but I can't easily tell anymore who originally wrote what)+Copyright Jonathan Tang (but there isn't much of his stuff left). This file is part of haskeem. haskeem is free software; you can redistribute it and/or modify@@ -19,14 +18,15 @@ 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.15 2009-06-29 00:23:01 uwe Exp $ -}+$Id: lispdata.hs,v 1.17 2009-08-06 05:05:15 uwe Exp $ -} module LispData (LispVal(Symbol, Boolean, Char, Delay, DottedList, IntNumber, RatNumber, FltNumber, Func, IOPrim, List, Port, Prim, Socket, String, Vector), LispError(NumArgs, TypeMismatch, Parser, BadSpecial, NotFunction,- UnboundVar, Default, OutOfRange, VectorBounds, UserException),+ UnboundVar, Default, OutOfRange, VectorBounds, UserException,+ DelCont), ThrowsError, Env, IOThrowsError, liftThrows, myRatPInf, myRatNInf, myRatNaN, myFltPInf, myFltNInf, myFltNaN, lispTrue, lispFalse) where@@ -144,7 +144,8 @@ lispTrue = Boolean True lispFalse = Boolean False --- A lisp error: these get processed when an error of some kind occurs+-- A lisp error: these get processed when an error of some kind occurs;+-- a DelCont isn't an error, but it is an unusual condition... data LispError = NumArgs String Integer [LispVal] | TypeMismatch String String LispVal@@ -156,6 +157,7 @@ | OutOfRange String Double | VectorBounds Integer LispVal | UserException LispVal+ | DelCont LispVal instance Show LispError where show = showError @@ -179,6 +181,7 @@ "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
Parser.hs view
@@ -1,8 +1,7 @@ {- Copyright 2008 Uwe Hollerbach <uh@alumni.caltech.edu> Portions of this were derived from Jonathan Tang's haskell tutorial "Write yourself a scheme in 48 hours" and are thus-Copyright Jonathan Tang-(but I can't easily tell anymore who originally wrote what)+Copyright Jonathan Tang (but there isn't much of his stuff left). This file is part of haskeem. haskeem is free software; you can redistribute it and/or modify@@ -19,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.15 2009-07-27 02:01:04 uwe Exp $ -}+$Id: parser.hs,v 1.16 2009-08-06 05:05:15 uwe Exp $ -} module Parser (readExpr, readExprList, readNumber, specialSymbolChars) where import Prelude
WriteNumber.hs view
@@ -1,8 +1,7 @@ {- Copyright 2008 Uwe Hollerbach <uh@alumni.caltech.edu> Portions of this were derived from Jonathan Tang's haskell tutorial "Write yourself a scheme in 48 hours" and are thus-Copyright Jonathan Tang-(but I can't easily tell anymore who originally wrote what)+Copyright Jonathan Tang (but there isn't much of his stuff left). This file is part of haskeem. haskeem is free software; you can redistribute it and/or modify@@ -19,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: writenumber.hs,v 1.14 2009-05-31 01:41:08 uwe Exp $ -}+$Id: writenumber.hs,v 1.15 2009-08-06 05:05:15 uwe Exp $ -} module WriteNumber (writeNum, ilogb) where import Prelude
callcc.scm view
@@ -1,5 +1,5 @@ ; Copyright 2009 Uwe Hollerbach <uh@alumni.caltech.edu>-; $Id: callcc.scm,v 1.2 2009-07-11 03:59:28 uwe Exp $+; $Id: callcc.scm,v 1.4 2009-08-06 04:19:18 uwe Exp $ ; BSD3 ; "poor man's" continuations: one-shot, limited lifespan, and while they@@ -15,6 +15,44 @@ (defmacro (let/cc1 k . body) `(call/cc1 (lambda (,k) ,@body)))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;++; From Queinnec, "A Library of Continuations":+; call/cc via delimited continuations+; This obviously requires that reset/shift or prompt/control+; can handle the whole enchilada, not just within a single s-expr++; call/cc expressed via prompt/control: given a program P which+; does not use prompt/control, provide call/cc as++; I think this uses different syntax than my version...+; (control (lambda (pc) ...)) -> (control pc ...) in mine;+; more like the reset/shift version below++;;(let ()+;; (define (call/cc f)+;; (control (lambda (pc)+;; (pc (f (lambda (v)+;; (control (lambda (ignore-pc) (pc v)))))))))+;; (prompt P))++; translated into my version... I think++;;(let ()+;; (define (call/cc f)+;; (control pc (pc (f (lambda (v)+;; (control ignore-pc (pc v)))))))+;; (prompt P))++; call/cc expressed via reset/shift: given a program P which+; does not use reset/shift, provide call/cc as++;;(let ()+;; (define (call/cc f)+;; (shift pc (pc (f (lambda (v)+;; (shift ignore-pc (pc v)))))))+;; (reset P)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; some tests
+ delTEST.scm view
@@ -0,0 +1,642 @@+; (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")
deltest.scm view
@@ -18,170 +18,200 @@ (write-string "examples from community.schemewiki.org\n") -(write-string "should be 6\t\t")-(display (+ 1 (reset (+ 2 3))))-(newline)+(write-string "r should be 6\t\t")+(sandbox+ (display (+ 1 (reset (+ 2 3))))+ (newline)) -(write-string "should be (1 2)\t\t")-(display (cons 1 (reset (cons 2 '()))))-(newline)+(write-string "r should be (1 2)\t")+(sandbox+ (display (cons 1 (reset (cons 2 '()))))+ (newline)) -(write-string "should be 4\t\t")-(display (+ 1 (reset (+ 2 (shift k 3)))))-(newline)+(write-string "r should be 4\t\t")+(sandbox+ (display (+ 1 (reset (+ 2 (shift k 3)))))+ (newline)) -(write-string "should be (1 3)\t\t")-(display (cons 1 (reset (cons 2 (shift k (cons 3 '()))))))-(newline)+(write-string "r should be (1 3)\t")+(sandbox+ (display (cons 1 (reset (cons 2 (shift k (cons 3 '()))))))+ (newline)) -(write-string "should be 10\t\t")-(display (+ 1 (reset (+ 2 (shift k (+ 3 (k 4)))))))-(newline)+(write-string "r should be 10\t\t")+(sandbox+ (display (+ 1 (reset (+ 2 (shift k (+ 3 (k 4)))))))+ (newline)) -(write-string "should be 14\t\t")-(display (+ 1 (reset (+ 2 (shift k (+ 3 (k 5) (k 1)))))))-(newline)+(write-string "r should be 14\t\t")+(sandbox+ (display (+ 1 (reset (+ 2 (shift k (+ 3 (k 5) (k 1)))))))+ (newline)) -(write-string "should be (1 3 2 4)\t")-(display (cons 1 (reset (cons 2 (shift k (cons 3 (k (cons 4 '()))))))))-(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 "should be (1 3 2 2 4)\t")-(display (cons 1 (reset (cons 2 (shift k (cons 3 (k (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 "should be 2\t\t")-(reset (display (begin (shift k1 (k1 1)) (shift k2 (k2 2)))))-(newline)+(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 "should be 12\t\t")-(reset (begin (display (shift k1 (k1 1))) (display (shift k2 (k2 2)))))-(newline)+(write-string "r should be 12\t\t")+(sandbox+ (reset (begin (display (shift k1 (k1 1))) (display (shift k2 (k2 2)))))+ (newline)) -(write-string "should be 12\t\t")-(reset (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 "should be 134234\t")-(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 (begin (k1 (display 1)) (k1 (display 2))))+ (shift0 k2 (begin (k2 (display 3)) (k2 (display 4))))))+ (newline)) -(write-string "should be 134234\t")-(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 (begin (shift0 k1 (k1 (display 1)) (k1 (display 2)))+ (shift0 k2 (k2 (display 3)) (k2 (display 4)))))+ (newline)) -(write-string "should be 134234\t")-(reset0 (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 "should be 13564562356456\n\t ")-(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 "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 "should be 57\t\t")-(display (+ 1 (reset (+ 2 (shift k1 (+ 3- (k1 5)- (k1 1)- (reset (* 10 (shift k2 (+ 3 (k2 4)))))- ))))))-(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 "should be 59\t\t")-(display (+ 1 (reset (+ 2 (shift k1 (+ 3- (k1 5)- (k1 1)- (reset (* 10 (shift k2 (+ (k1 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 "should be 1 3 2\t\t")-(reset (begin (write-string "1 ")- (shift c (begin (c 'ignore)- (write-string "2 ")))- (write-string "3 ")))-(newline)-(write-string "should be 1 3 2\t\t")-(reset (begin (write-string "1 ")- (shift c (c 'ignore) (write-string "2 "))- (write-string "3 ")))-(newline)-(write-string "should be 1 3 2\t\t")-(reset (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 (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 "should be 1 2 3\t\t")-(reset (begin (write-string "1 ")- (shift c (begin (write-string "2 ")- (c 'ignore)))- (write-string "3 ")))-(newline)-(write-string "should be 1 2 3\t\t")-(reset (begin (write-string "1 ")- (shift c (write-string "2 ") (c 'ignore))- (write-string "3 ")))-(newline)-(write-string "should be 1 2 3\t\t")-(reset (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 (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 "should be 1 3 2 3\t")-(reset (begin (write-string "1 ")- (shift c (begin (c 'ignore)- (write-string "2 ")- (c 'ignore)))- (write-string "3 ")))-(newline)-(write-string "should be 1 3 2 3\t")-(reset (begin (write-string "1 ")- (shift c (c 'ignore) (write-string "2 ") (c 'ignore))- (write-string "3 ")))-(newline)-(write-string "should be 1 3 2 3\t")-(reset (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 (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 "should be (a)\t\t")-(display (reset (cons 'a (reset (shift f (shift g '()))))))-(newline)+(write-string "r should be (a)\t")+(sandbox+ (display (reset (cons 'a (reset (shift f (shift g '()))))))+ (newline)) -(write-string "should be ()\t\t")-(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 "should be (a)\t\t")-(display (reset (let ((y (shift f (cons 'a (f '()))))) (shift g y))))-(newline)+(write-string "r should be (a)\t")+(sandbox+ (display (reset (let ((y (shift f (cons 'a (f '()))))) (shift g y))))+ (newline)) -(write-string "should be ()\t\t")-(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)) ; 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.@@ -199,68 +229,77 @@ ;;; (control f (begin (f (display 3)) (f (display 4)))))) ;;;(newline) -(write-string "should be (a)\t\t")-(display (reset (let ((y (shift f (cons 'a (f '()))))) (shift g y))))-(newline)+(write-string "r should be (a)\t")+(sandbox+ (display (reset (let ((y (shift f (cons 'a (f '()))))) (shift g y))))+ (newline)) -(write-string "should be (a)\t\t")-(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 "should be ()\t\t")-(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 "should be ()\t\t")-(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 "should be (a b)\t\t")-(display- (reset- (reset (cons 'a (reset- (let ((y (shift f (shift g (cons 'b (f '()))))))- (shift h 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 "should be (a)\t\t")-(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 "should be (b)\t\t")-(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 "should be ()\t\t")-(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 "should be (1 3)\t\t")- (write-string "should be (1 4 2 5)\t"))- (display- (cons 1 (reset (cons 2 (if flag- (shift k1 (cons 3 '()))- (shift k2 (cons 4 (k2 (cons 5 '())))))))))- (newline))+ (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)@@ -268,13 +307,14 @@ (write-string "test 2: reverse of previous\n") (define (doit2 flag) (if flag- (write-string "should be (1 4 2 5)\t")- (write-string "should be (1 3)\t\t"))- (display- (cons 1 (reset (cons 2 (if flag- (shift k2 (cons 4 (k2 (cons 5 '()))))- (shift k1 (cons 3 '())))))))- (newline))+ (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)@@ -282,16 +322,16 @@ (write-string "test 3: wrong? expansion of test 1\n") (define (doit3 flag)- (write-string "should be (1 4 3)\t") ; independent of flag- (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))+ (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)@@ -299,15 +339,15 @@ (write-string "test 4: expansion of test 2\n") (define (doit4 flag) (if flag- (write-string "should be (1 4 2 3)\t")- (write-string "should be (1 4 2 5)\t"))- (display- (cons 1- (let ((k2 (lambda (v2)- (reset (cons 2 (if flag (cons 3 '()) v2))))))- (reset (cons 4 (k2 (cons 5 '())))))- ))- (newline))+ (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)@@ -315,35 +355,33 @@ (write-string "test 5: modified version, with (shift) in both arms of (if)\n") (define (doit5 flag) (if flag- (write-string "should be (1 3 2 4)\t")- (write-string "should be (1 5 2 6)\t"))- (display- (cons 1- (reset (cons 2 (if flag- (shift k1 (cons 3 (k1 (cons 4 '()))))- (shift k2 (cons 5 (k2 (cons 6 '())))))))))- (newline))+ (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) -; This one seems to be right either way... had to lift the (if flag)-; outside the (reset), which seems both intuitive and counter-intuitive.-; :-/- (write-string "test 6: modified version of test 5, with (if) lifted out of (reset)\n") (define (doit6 flag) (if flag- (write-string "should be (1 3 2 4)\t")- (write-string "should be (1 5 2 6)\t"))- (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))+ (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)@@ -352,26 +390,31 @@ (write-string "prompt/control examples\n") (write-string "should be 3\t\t")-(display (prompt (* 2 (control f 3))))-(newline)+(sandbox+ (display (prompt (* 2 (control f 3))))+ (newline)) (write-string "should be 30\t\t")-(display (prompt (* 2 (control f (* 5 (f 3))))))-(newline)+(sandbox+ (display (prompt (* 2 (control f (* 5 (f 3))))))+ (newline)) (write-string "should be 12\t\t")-(display (prompt (* 2 (control f (f (f 3))))))-(newline)+(sandbox+ (display (prompt (* 2 (control f (f (f 3))))))+ (newline)) (write-string "should be 6\t\t")-(display ((prompt (* 2 (control f f))) 3))-(newline)+(sandbox+ (display ((prompt (* 2 (control f f))) 3))+ (newline)) (write-string "should be 35\t\t")-(display (prompt (* 5- (prompt (* 2- (control f2 (* 3 (control f3 7))))))))-(newline)+(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@@ -387,33 +430,39 @@ (newline)) (write-string "should be 21\t\t")-(display (prompt (* 5- ((lambda (x) (control f1 x))- (* 3 (control f2 (* 2 (f2 7))))))))-(newline)+(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")-(display (prompt0 (* 2 (control0 f 3))))-(newline)+(sandbox+ (display (prompt0 (* 2 (control0 f 3))))+ (newline)) (write-string "should be 30\t\t")-(display (prompt0 (* 2 (control0 f (* 5 (f 3))))))-(newline)+(sandbox+ (display (prompt0 (* 2 (control0 f (* 5 (f 3))))))+ (newline)) (write-string "should be 12\t\t")-(display (prompt0 (* 2 (control0 f (f (f 3))))))-(newline)+(sandbox+ (display (prompt0 (* 2 (control0 f (f (f 3))))))+ (newline)) (write-string "should be 6\t\t")-(display ((prompt0 (* 2 (control0 f f))) 3))-(newline)+(sandbox+ (display ((prompt0 (* 2 (control0 f f))) 3))+ (newline)) (write-string "should be 7\t\t")-(display (prompt0 (* 5- (prompt0 (* 2- (control0 f2 (* 3 (control0 f3 7))))))))-(newline)+(sandbox+ (display (prompt0 (* 5+ (prompt0 (* 2+ (control0 f2 (* 3 (control0 f3 7))))))))+ (newline)) (write-string "should be 7\t\t") (sandbox@@ -438,31 +487,31 @@ (write-string "reset/shift examples\n") (write-string "should be 3\t\t")-(display (reset (* 2 (shift f 3))))-(newline)+(sandbox+ (display (reset (* 2 (shift f 3))))+ (newline)) (write-string "should be 30\t\t")-(display (reset (* 2 (shift f (* 5 (f 3))))))-(newline)+(sandbox+ (display (reset (* 2 (shift f (* 5 (f 3))))))+ (newline)) (write-string "should be 12\t\t")-(display (reset (* 2 (shift f (f (f 3))))))-(newline)+(sandbox+ (display (reset (* 2 (shift f (f (f 3))))))+ (newline)) (write-string "should be 6\t\t")-(display ((reset (* 2 (shift f f))) 3))-(newline)+(sandbox+ (display ((reset (* 2 (shift f f))) 3))+ (newline)) (write-string "should be 35\t\t")-(display (reset (* 5- (reset (* 2- (shift f2 (* 3 (shift 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+(sandbox+ (display (reset (* 5+ (reset (* 2+ (shift f2 (* 3 (shift f3 7))))))))+ (newline)) (write-string "should be 7\t\t") (sandbox@@ -473,33 +522,39 @@ (newline)) (write-string "should be 42\t\t")-(display (reset (* 5- ((lambda (x) (shift f1 x))- (* 3 (shift f2 (* 2 (f2 7))))))))-(newline)+(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")-(display (reset0 (* 2 (shift0 f 3))))-(newline)+(sandbox+ (display (reset0 (* 2 (shift0 f 3))))+ (newline)) (write-string "should be 30\t\t")-(display (reset0 (* 2 (shift0 f (* 5 (f 3))))))-(newline)+(sandbox+ (display (reset0 (* 2 (shift0 f (* 5 (f 3))))))+ (newline)) (write-string "should be 12\t\t")-(display (reset0 (* 2 (shift0 f (f (f 3))))))-(newline)+(sandbox+ (display (reset0 (* 2 (shift0 f (f (f 3))))))+ (newline)) (write-string "should be 6\t\t")-(display ((reset0 (* 2 (shift0 f f))) 3))-(newline)+(sandbox+ (display ((reset0 (* 2 (shift0 f f))) 3))+ (newline)) (write-string "should be 7\t\t")-(display (reset0 (* 5- (reset0 (* 2- (shift0 f2 (* 3 (shift0 f3 7))))))))-(newline)+(sandbox+ (display (reset0 (* 5+ (reset0 (* 2+ (shift0 f2 (* 3 (shift0 f3 7))))))))+ (newline)) (write-string "should be 7\t\t") (sandbox@@ -510,12 +565,13 @@ (newline)) (write-string "should be 42\t\t")-(display (reset0 (* 5- ((lambda (x) (shift0 f1 x))- (* 3 (shift0 f2 (* 2 (f2 7))))))))-(newline)+(sandbox+ (display (reset0 (* 5+ ((lambda (x) (shift0 f1 x))+ (* 3 (shift0 f2 (* 2 (f2 7))))))))+ (newline)) -(write-string "something actually useful! a small table of factorials\n")+(write-string "r something actually useful! a small table of factorials\n") ; Eventually we want to be able to use code like this: @@ -541,14 +597,15 @@ (define to 21) (define step 3) -(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))+(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@@ -561,14 +618,15 @@ (write-string "\"should be\"... but they look plausible\n") (define (doit7 flag)- (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))+ (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@@ -580,3 +638,5 @@ "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")
haskeem.cabal view
@@ -1,5 +1,5 @@ Name: haskeem-Version: 0.7.9+Version: 0.7.12 Homepage: http://www.korgwal.com/haskeem/ Author: Uwe Hollerbach <uh@alumni.caltech.edu> Maintainer: Uwe Hollerbach <uh@alumni.caltech.edu>@@ -7,11 +7,11 @@ Description: This is a moderately complete small scheme interpreter. It implements most of R6RS, with the exception of call/cc. It is however starting to have a set of delimited- continuations (implemented as macros, so not quite "native").- It has a macro system, although not R6RS hygienic macros.- It is also not necessarily fully tail-recursive; so it's- not industrial-strength. For playing with or learning- scheme, it should be pretty good.+ continuations, reset/shift et al. It has a macro system,+ although not R6RS hygienic macros. It is also not+ necessarily fully tail-recursive; so it's not+ industrial-strength. For playing with or learning scheme,+ it should be pretty good. License: GPL License-File: LICENSE Cabal-Version: >= 1.2
haskeem.hs view
@@ -1,8 +1,7 @@ {- Copyright 2008 Uwe Hollerbach <uh@alumni.caltech.edu> Portions of this were derived from Jonathan Tang's haskell tutorial "Write yourself a scheme in 48 hours" and are thus-Copyright Jonathan Tang-(but I can't easily tell anymore who originally wrote what)+Copyright Jonathan Tang (but there isn't much of his stuff left). This file is part of haskeem. haskeem is free software; you can redistribute it and/or modify@@ -19,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.38 2009-07-27 04:46:22 uwe Exp $ -}+$Id: haskeem.hs,v 1.43 2009-08-08 05:09:00 uwe Exp $ -} module Main where import Prelude@@ -43,7 +42,7 @@ -- haskeem version version :: String-version = "0.7.9"+version = "0.7.12" -- a variable under which any command-line arguments to a script are -- made available; empty for interactive mode@@ -63,7 +62,7 @@ evalAndPrint :: Env -> Bool -> String -> InputT IO () evalAndPrint env pflag expr = do ret <- liftIO (runErrorT (liftThrows (readExpr (dropWhile isSpace expr))- >>= evalLisp env 0))+ >>= evalPP env >>= evalLisp env [] 0)) case ret of Left err -> outputStrLn (show err) Right val -> if pflag then outputStrLn (show val) else outputStr ""
haskeem_readline.hs view
@@ -1,8 +1,7 @@ {- Copyright 2008 Uwe Hollerbach <uh@alumni.caltech.edu> Portions of this were derived from Jonathan Tang's haskell tutorial "Write yourself a scheme in 48 hours" and are thus-Copyright Jonathan Tang-(but I can't easily tell anymore who originally wrote what)+Copyright Jonathan Tang (but there isn't much of his stuff left). This file is part of haskeem. haskeem is free software; you can redistribute it and/or modify@@ -25,14 +24,14 @@ import Prelude import IO import System-import Monad+import Monad() import Control.Monad.Error as CME import Control.OldException as CE import Data.Char -- import System.Console.Readline-import System.Posix.Signals-import Control.Concurrent-import Data.Typeable+import System.Posix.Signals()+import Control.Concurrent()+import Data.Typeable() import LispData import Parser@@ -43,7 +42,7 @@ -- haskeem version version :: String-version = "0.7.9"+version = "0.7.12" -- a variable under which any command-line arguments to a script are -- made available; empty for interactive mode@@ -61,11 +60,12 @@ -- (but errors are always printed) evalAndPrint :: Env -> Bool -> String -> IO ()-evalAndPrint env print expr =- do ret <- runErrorT (liftThrows (readExpr expr) >>= evalLisp env 0)+evalAndPrint env pflag expr =+ do ret <- runErrorT (liftThrows (readExpr (dropWhile isSpace expr))+ >>= evalPP env >>= evalLisp env [] 0) case ret of Left err -> hPutStrLn stderr (show err)- Right val -> if print then putStrLn (show val) else putStr ""+ Right val -> if pflag then putStrLn (show val) else putStr "" -- if the environment variable HASKEEM_INIT is set, try to load that file @@ -73,7 +73,8 @@ runInit env = (do ret <- CE.try (getEnv "HASKEEM_INIT") case ret of- Left err -> return "(write-string \"no init file loaded\n\")"+ Left err -> return ("(write-string \"no init file loaded: " +++ show err ++ "\n\")") Right val -> return ("(load \"" ++ val ++ "\")")) >>= evalAndPrint env False
stdlib.scm view
@@ -1,8 +1,7 @@ ; Copyright 2008 Uwe Hollerbach <uh@alumni.caltech.edu> ; Portions of this were derived from Jonathan Tang's haskell ; tutorial "Write yourself a scheme in 48 hours" and are thus-; Copyright Jonathan Tang-; (but I can't easily tell anymore who originally wrote what)+; Copyright Jonathan Tang (but there isn't much of his stuff left). ; This file is part of haskeem. ; haskeem is free software; you can redistribute it and/or modify@@ -19,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.42 2009-07-03 23:17:01 uwe Exp $+; $Id: stdlib.scm,v 1.43 2009-08-06 05:05:15 uwe Exp $ ; The haskeem standard library @@ -111,12 +110,13 @@ (define (compose f g) (lambda args (apply f (apply g args)))) -;;; (define fcdr (compose force cdr))-(define (fcdr x)- (let ((cx (cdr x)))- (if (promise? cx)- (force cx)- cx)))+(define fcdr (compose force cdr))++;;;(define (fcdr x)+;;; (let ((cx (cdr x)))+;;; (if (promise? cx)+;;; (force cx)+;;; cx))) (define (cycle lst) (letrec ((next (lambda (cur)