{- Copyright 2008 Uwe Hollerbach Portions of this were derived from Jonathan Tang's haskell tutorial "Write yourself a scheme in 48 hours" and are thus Copyright Jonathan Tang (but 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 it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. haskeem is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with haskeem; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA $Id: evaluator.hs,v 1.40 2009-08-08 05:08:59 uwe Exp $ -} module Evaluator (evalLisp, evalPP) where import Prelude import IO import Control.Exception as CE() import Control.Monad.Error as CME import Data.IORef() import qualified Data.IntMap as DIM import LispData import Environment import Library errNumArgs name want got = throwError (NumArgs name want got) errTypeMismatch name want got = throwError (TypeMismatch name want got) errBadForm name args = throwError (BadSpecial ("bad " ++ name ++ " form") (List args)) -- Debugging output: either inside haskeem while tracing something, -- or inside haskeem while debugging haskeem remark str = liftIO (hPutStrLn stderr str) progError = error "internal error!" {-# INLINE mapML #-} 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 isTrue :: LispVal -> Bool isTrue (Boolean False) = False isTrue _ = True -- Check that a variable is unique in a list, -- for the various forms of "let" and for "do" uniqCheck :: String -> [LispVal] -> Bool uniqCheck _ [] = True uniqCheck name ((List ((Symbol var):_)):rest) = if name == var then False else uniqCheck name rest uniqCheck _ _ = progError -- Check the variable bindings in the various forms of "let". -- The "uniq" boolean argument specifies whether or not multiple -- instances of the same name are allowed. letCheck :: Bool -> [LispVal] -> Bool letCheck _ [] = True letCheck uniq ((List [Symbol var, _]):rest) = letCheck uniq rest && ((not uniq) || (uniq && uniqCheck var rest)) letCheck _ _ = False -- Ditto for "do", except that we have two kinds of syntax: -- (var-name init-expr step-expr) and (var-name init-expr) doCheck :: [LispVal] -> Bool doCheck [] = True doCheck ((List [Symbol var, _]):rest) = doCheck rest && uniqCheck var rest doCheck ((List [Symbol var, _, _]):rest) = doCheck rest && uniqCheck var rest doCheck _ = False -- Ditto for "define", "defmacro", and "lambda" params lists and dotted-lists paramsCheck :: [LispVal] -> Bool paramsCheck [] = True paramsCheck ((Symbol var):rest) = paramsCheck rest && uC var rest where uC _ [] = True uC name ((Symbol var2):rest) = if name == var2 then False else uC name rest uC _ _ = progError paramsCheck _ = False -- This is the apply function, the generic -- omnipotent thing that does all the work doApply :: Bool -> String -> [String] -> (Maybe String) -> [LispVal] -> Env -> [[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 >> (liftIO (bindVars closure (zip params args))) >>= bindVarArgs varargs >>= evalBody where remainingArgs = drop (length params) args num = toInteger . length evalBody env = mapML (evalLisp env dcs ql) body bindVarArgs arg env = case arg of Just argName -> liftIO (bindVars env [(argName, List (remainingArgs))]) Nothing -> return env prtTrace = if trace then remark ("trace: " ++ name ++ " <- " ++ (show (List args))) >> return True else return False apply :: [[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) makeNormalFunc = makeFunc Nothing makeVarargsFunc = makeFunc . Just . show makeMacro varargs env params body = return (Func (map show params) varargs body env Nothing True) makeNormalMacro = makeMacro Nothing makeVarargsMacro = makeMacro . Just . show 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", "trace", "dump-bindings"] isSpecialForm (Symbol s) = seek s specialForms where seek _ [] = False seek s (sf:sfs) = if s == sf then True else seek s sfs isSpecialForm _ = False isInt (IntNumber _) = True isInt _ = False getInt (IntNumber n) = n isStr (String _) = True isStr _ = False getStr (String s) = s isList (List _) = True isList _ = False getList (List l) = l isDL (DottedList _ _) = True isDL _ = False getDLh (DottedList h _) = h getDLt (DottedList _ t) = t isVec (Vector _ _) = True isVec _ = False getVecL (Vector l _) = l getVecV (Vector _ v) = v -- This is an internal symbol which temporarily replaces "unquote" and -- "unquote-splicing" after these have evaluated the expression(s): evalQQ -- looks for this marker and lifts the remainder of the list up by one -- level, turning (1 2 (' unq' 7)) into (1 2 7): this makes `(1 2 ,(+ 3 4)) -- come out right (otherwise it turns into (1 2 (7)). Notice that this -- begins with a space: that's necessary to guarantee there will be no -- collisions with user-generated symbols. unq :: String unq = " unq" -- This is the list-context unquote-lifting function: liftLUnq :: [LispVal] -> [LispVal] liftLUnq lst = lunq [] lst where lunq acc [] = acc lunq acc (l@(List ((Symbol sym):vals)):ls) = if sym == unq then lunq (acc ++ vals) ls else lunq (acc ++ [l]) ls lunq acc (l:ls) = lunq (acc ++ [l]) ls -- and the scalar-context equivalent liftSUnq :: LispVal -> IOThrowsError LispVal liftSUnq l@(List ((Symbol sym):vals)) = if sym == unq then if (length vals) == 1 then return (head vals) else throwError (Default "list unquote form in scalar context") else return l liftSUnq v = return v -- evalQQ is more or less a specialized version of evalLisp: It just walks -- the tree, returning everything unevaluated, except if it finds an unquote -- or an unquote-splicing at the right quote level; these it evaluates via -- evalLisp and patches into the tree evalQQ :: Env -> [[LispVal]] -> Integer -> 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 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 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))) where isLL [] = True isLL ((List _):ls) = isLL ls isLL _ = False peel [] = [] peel ((List l):ls) = l ++ (peel ls) -- lists, dotted-lists, and vectors get traversed evalQQ env dcs ql (List con) = mapM (evalQQ env dcs ql) 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 if isList vcab then return (List (head ++ (getList vcab))) else if isDL vcab then return (DottedList (head ++ (getDLh vcab)) (getDLt vcab)) else return (DottedList head vcab) 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 [] = [] remkey ((_, v):vs) = v:(remkey vs) addkey _ [] = [] addkey n (v:vs) = (n, v):(addkey (n+1) vs) -- anything else gets returned unchanged evalQQ _ _ _ val@_ = return val -- 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 -> [[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 -- Special forms must go here, before the generic (function : args) stuff -- TODO: implement set-car! and set-cdr! (but how?) -- (apply) doesn't strictly need to be a special form, but it's far more -- convenient to have it here; otherwise, we have to do all sorts of -- twisting to make it all work. evalLisp env 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 -- provided here more conveniently than in library.hs. In order to -- make stuff like "(map eval (list 'foo 'bar 'baz))" work in addition -- to "(eval 'foo)", there is a hack "(define (eval x) (eval x))" in -- stdlib.scm. Hmmm... reading R6RS more closely, it seems that they -- do not make eval work in the current environment; it's some -- sanitized top-level environment. That would make it possible to -- move this into the libraries... I'd just have to provide access to -- the (or a) top-level environment. evalLisp env 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 -- as "eval". It would most likely be safe to just provide access to -- the top-level environment here; it's really unlikely that anyone -- wants to (or should be able to) call (load) from within some -- function and modify the environment seen within that function. evalLisp env dcs ql (List [Symbol "load", arg]) = do fname <- evalLisp env dcs ql arg if isStr fname 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 dcs ql (List (Symbol "begin" : args)) = mapML (evalLisp env dcs ql) args evalLisp _ _ _ (List [Symbol "quote", val]) = return val evalLisp env dcs ql (List [Symbol "quasiquote", val]) = evalQQ env dcs (ql + 1) val >>= liftSUnq evalLisp _ _ _ (List (Symbol "unquote" : args)) = throwError (Default ("naked unquote form: " ++ (show args))) evalLisp _ _ _ (List (Symbol "unquote-splicing" : args)) = throwError (Default ("naked unquote-splicing form: " ++ (show args))) evalLisp env dcs ql (List [Symbol "set!", Symbol var, val]) = evalLisp env dcs ql val >>= setVar env 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 dcs ql 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 (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 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 dcs ql obj let n = getVecL vec setVar env var (Vector n (DIM.fromAscList (addkey val (fromInteger n)))) else throwError (Default ("bad vector-fill! form: " ++ (show var) ++ " is not a vector")) where addkey _ 0 = [] 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) if isVec vec then do lk <- evalLisp env dcs ql obj let l = getVecL vec k = getInt lk if (isInt lk) && (k > 0) then do let new = if k < l then rem (getVecV vec) l k else add (getVecV vec) k l setVar env var (Vector k new) else throwError (Default ("bad vector-resize! size: " ++ (show k))) else throwError (Default ("bad vector-resize! form: " ++ (show var) ++ " is not a vector")) where rem vec h l = if h == l then vec else rem (DIM.delete (fromInteger l) vec) h (l + 1) add vec h l = if h == l then vec else add (DIM.insert (fromInteger l) 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 _ (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" : 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 _ (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" : 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)) = if paramsCheck params then makeNormalFunc env params body else errBadForm "lambda" params 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 dcs _ (List (Symbol "lambda" : varargs@(Symbol _) : body)) = makeVarargsFunc varargs env [] body evalLisp env dcs ql (List [Symbol "if", pred, tcase, fcase]) = do result <- evalLisp env dcs ql pred 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 case result of Boolean False -> return lispFalse _ -> evalLisp env dcs ql tcase 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 dcs ql t case result of Boolean False -> return lispFalse _ -> eva env ts result 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 dcs ql 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 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 return (True, ret) evc_clause env (List (pred : args)) = 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 dcs ql) 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] 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 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 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 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 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 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) exn (List [Symbol var, _]) = var exv (List [Symbol _, val]) = val 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 dcs ql) (map exv params) mapM (doSet envn) (repl varn varv) >> 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 dcs ql (List (Symbol "letrec*" : List params : body)) = if letCheck False params then dolr params body env else errBadForm "letrec*" params where dolr params body env = do let varn = map exn params envn <- liftIO (bindVars env varn) mapM (evSet envn) params >> mapML (evalLisp envn dcs ql) body exn (List [Symbol var, _]) = (var, lispFalse) evSet env (List [Symbol var, val]) = evalLisp env dcs ql val >>= setVar env var 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 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_clause env (List (Symbol "else" : 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 dcs ql) 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 _ [] = False 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 dcs ql) body) (\err -> do let errval = unpackErr err liftIO (bindVars env [(var, errval)]) >>= evc err 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 return (True, ret) evc_clause env (List (pred : args)) = 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 dcs ql) 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] -- This creates an internal variable for each delay object where its value -- will be stored once it is forced. We avoid collisions with any symbols -- that the user might define by simply beginning the variable name with a -- space: the parser won't let such strings through as symbols, so we are -- never in the situation where something might clash. evalLisp env _ _ (List [Symbol "delay", val]) = do dval <- getVar env delayCounter let count = getInt dval do setVar env delayCounter (IntNumber (count + 1)) return (Delay val env (" delay." ++ (show count))) 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) if alreadyDef then getVar env tag else forceEval vali >>= defineVar env tag else return vali where isDelay (Delay _ _ _) = True isDelay _ = False getTag (Delay _ env tag) = (env, tag) forceEval (Delay obj env _) = evalLisp env dcs ql obj 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 dcs ql) (map exi params) envn <- liftIO (bindVars env (zip names inits)) doloop envn names test steps else errBadForm "do" params where exn (List [Symbol var, _]) = var exn (List [Symbol var, _, _]) = var exi (List [Symbol _, init]) = init exi (List [Symbol _, init, _]) = init exs (List [Symbol var, _]) = Symbol var exs (List [Symbol _, _, step]) = step doSet env (n,v) = setVar env n v doloop env names (test:rets) steps = do tval <- evalLisp env dcs ql test 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 -- 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"]) = 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 -- we can trace just sub-functions which are defined within a function -- but which are not visible in the top-level environment. Evaluating -- the function name is pretty trivial, we could just require writing -- (trace 'function #t), but tracing sub-functions needs a special -- form, because it needs access to the current environment rather than -- the top-level environment. -- We require the literal form '(trace name #t/f), rather than some -- 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]) = 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 if isPr val then throwError (Default "can't trace primitives") else if (isF val) -- TODO: this can be cleaned up a bit more... doit! then if (isTrue swval) then (remark ("trace " ++ var ++ " on")) >> setVar env var (trOn var val) >> return lispTrue else (remark ("trace " ++ var ++ " off")) >> setVar env var (trOff val) >> return lispFalse else errBadForm "trace" ((Symbol var):[sw]) where isPr (Prim _) = True isPr (IOPrim _) = True isPr _ = False 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 -- 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 if isPort vali then dumpEnv env (getPort vali) else errBadForm "dump-bindings" [val] where isPort (Port _) = True isPort _ = False getPort (Port p) = p getPort _ = progError -- The generic (function : args) stuff; 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)) = if isSpecialForm function then throwError (BadSpecial "bad syntax for special form" function) else do func <- evalLisp env dcs ql 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 isM _ = False isT (Func _ _ _ _ (Just _) _) = True isT _ = False chEnv (Func pars vars bod envo name mac) envn = Func pars vars bod envn name mac prtTrace trace vals = if trace then remark (" -> " ++ (show vals)) >> return vals else return vals evalLisp _ _ _ badForm = throwError (BadSpecial "Unrecognized special form" badForm)