{- 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.51 2010-01-18 00:08:49 uwe Exp $ -} {-# LANGUAGE FlexibleContexts #-} 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 :: MonadError LispError m => String -> Integer -> [LispVal] -> m a errNumArgs name want = throwError . NumArgs name want errTypeMismatch :: MonadError LispError m => String -> String -> LispVal -> m a errTypeMismatch name want = throwError . TypeMismatch name want errBadForm :: MonadError LispError m => String -> [LispVal] -> m a errBadForm name = throwError . BadSpecial ("bad " ++ name ++ " form") . List -- Debugging output: either inside haskeem while tracing something, -- or inside haskeem while debugging haskeem remark :: MonadIO m => String -> m () remark = liftIO . hPutStrLn stderr mapML :: Monad m => (a -> m LispVal) -> [a] -> m LispVal mapML fn lst = mapMLA (List []) fn lst where mapMLA r _ [] = return r mapMLA _ f (x:xs) = do rn <- f x mapMLA rn f 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 "uniqCheck" -- 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 : rmdr) = if name == var2 then False else uC name rmdr uC _ _ = progError "paramsCheck" paramsCheck _ = False -- This is the apply function, the generic -- omnipotent thing that does all the work doApply :: Bool -> String -> [String] -> (Maybe String) -> [LispVal] -> Env -> EEnv -> [LispVal] -> Bool -> IOThrowsError LispVal doApply trace name params varargs body closure eenv args cflag = if num params /= num args && varargs == Nothing then errNumArgs (show body) (num params) args else do let app = zip params args ca = head app prtTrace envn <- liftIO (bindVars closure app) >>= bindVarArgs varargs let een = eeNewE eenv envn eenc = eeNewPE een (ca : eePE een) evalBody (if cflag then eenc else een) where remainingArgs = drop (length params) args num = toInteger . length evalBody ee = mapML (evalLisp ee) 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 :: EEnv -> LispVal -> [LispVal] -> IOThrowsError LispVal apply _ (Prim func) args = liftThrows (func args) apply _ (IOPrim func) args = func args apply eenv (Func params varargs body closure Nothing _ cflag) args = doApply False "" params varargs body closure eenv args cflag apply eenv (Func params varargs body closure (Just name) _ cflag) args = doApply True name params varargs body closure eenv args cflag apply _ func _ = throwError (NotFunction "apply got non-function" func) makeFunc, makeMacro :: Monad m => Maybe String -> Env -> [LispVal] -> [LispVal] -> m LispVal makeFunc varargs env params body = return (Func (map show params) varargs body env Nothing False False) makeMacro varargs env params body = return (Func (map show params) varargs body env Nothing True False) makeNormalFunc, makeNormalMacro :: Monad m => Env -> [LispVal] -> [LispVal] -> m LispVal makeNormalFunc = makeFunc Nothing makeNormalMacro = makeMacro Nothing makeVarargsFunc, makeVarargsMacro :: Monad m => LispVal -> Env -> [LispVal] -> [LispVal] -> m LispVal makeVarargsFunc = makeFunc . Just . show makeVarargsMacro = makeMacro . Just . show makeContFunc :: Monad m => Env -> [LispVal] -> [LispVal] -> m LispVal makeContFunc env params body = return (Func (map show params) Nothing body env Nothing False True) specialForms :: [String] specialForms = ["and", "apply", "begin", "case", "cond", "define", "defmacro", "delay", "do", "eval", "force", "gensym", "guard", "if", "lambda", "let", "let*", "letrec", "letrec*", "load", "or", "quasiquote", "quote", "set!", "unquote", "unquote-splicing", "vector-fill!", "vector-set!", "reset", "shift ", "trace", "dump-bindings"] isSpecialForm, isInt, isStr, isList, isDL, isVec :: LispVal -> Bool isSpecialForm (Symbol sym) = seek sym specialForms where seek _ [] = False seek s (sf:sfs) = (s == sf) || seek s sfs isSpecialForm _ = False isInt (IntNumber _) = True isInt _ = False getInt :: LispVal -> Integer getInt (IntNumber n) = n getInt _ = progError "getInt" isStr (String _) = True isStr _ = False getStr :: LispVal -> String getStr (String s) = s getStr _ = progError "getStr" isList (List _) = True isList _ = False getList :: LispVal -> [LispVal] getList (List l) = l getList _ = progError "getList" isDL (DottedList _ _) = True isDL _ = False getDLh :: LispVal -> [LispVal] getDLh (DottedList h _) = h getDLh _ = progError "getDLh" getDLt :: LispVal -> LispVal getDLt (DottedList _ t) = t getDLt _ = progError "getDLt" isVec (Vector _ _) = True isVec _ = False getVecL :: LispVal -> Integer getVecL (Vector l _) = l getVecL _ = progError "getVecL" getVecV :: LispVal -> DIM.IntMap LispVal getVecV (Vector _ v) = v getVecV _ = progError "getVecV" -- This is an internal symbol which temporarily replaces "unquote" and -- "unquote-splicing" after these have evaluated the expression(s): evalQQ -- 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 :: EEnv -> LispVal -> IOThrowsError LispVal -- "quasiquote", "unquote", and "unquote-splicing" might get evaluated, -- depending on quote level evalQQ eenv (List [Symbol "quasiquote", arg]) = do val <- evalQQ (eeQLIncr eenv) arg >>= liftSUnq return (List [Symbol "quasiquote", val]) evalQQ eenv (List (Symbol "unquote" : args)) = let een = eeQLDecr eenv in if eeQL eenv == 1 then do vals <- mapM (evalLisp een) args return (List (Symbol unq : vals)) else do vals <- mapM (evalQQ een) args return (List (Symbol "unquote" : liftLUnq vals)) evalQQ eenv (List (Symbol "unquote-splicing" : args)) = let een = eeQLDecr eenv in if eeQL eenv == 1 then do vals <- mapM (evalLisp een) args if isLL vals then return (List (Symbol unq : peel vals)) else throwError (Default ("bad unquote-splicing form: " ++ show args)) else do vals <- mapM (evalQQ een) args return (List (Symbol "unquote-splicing" : liftLUnq vals)) where isLL [] = True isLL ((List _):ls) = isLL ls isLL _ = False peel [] = [] peel ((List l):ls) = l ++ peel ls peel _ = progError "evalQQ/unquote-splicing" -- lists, dotted-lists, and vectors get traversed evalQQ eenv (List con) = mapM (evalQQ eenv) con >>= return . List . liftLUnq evalQQ eenv (DottedList con cab) = do vals <- mapM (evalQQ eenv) con vcab <- evalQQ eenv cab >>= liftSUnq let h = liftLUnq vals if isList vcab then return (List (h ++ getList vcab)) else if isDL vcab then return (DottedList (h ++ getDLh vcab) (getDLt vcab)) else return (DottedList h vcab) evalQQ eenv (Vector _ con) = do vals <- mapM (evalQQ eenv) (remkey (DIM.toAscList con)) let new = DIM.fromAscList (addkey 0 (liftLUnq vals)) return (Vector (toInteger (DIM.size new)) new) where remkey [] = [] remkey ((_, v) : vs) = v : remkey vs 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 attached. The unique identifier is to -- be able to identify which is the current hole in an expression if -- there are several interior operators enclosed within the scope of -- an exterior operator. -- TODO: check shift operators for syntactic correctness here? -- ie, check that the first arg is a symbol and not something else? -- probably a good idea... evalPP :: EEnv -> LispVal -> IOThrowsError LispVal evalPP eenv (List (Symbol "shift" : arg)) = do let env = eeE eenv argn <- mapM (evalPP eenv) arg cval <- getVar env contCounter let count = getInt cval csym = " cont." ++ show count setVar env contCounter (IntNumber (count + 1)) return (List (Symbol "shift " : Symbol csym : argn)) evalPP eenv (List args) = mapM (evalPP eenv) args >>= return . List -- everything else gets returned unchanged evalPP _ val = return val -- This is the main evaluator evalLisp :: EEnv -> LispVal -> IOThrowsError LispVal -- various simple things which evaluate to themselves evalLisp _ val@(String _) = return val evalLisp _ val@(IntNumber _) = return val evalLisp _ val@(RatNumber _) = return val evalLisp _ val@(FltNumber _) = return val evalLisp _ val@(Boolean _) = return val evalLisp _ val@(Char _) = return val evalLisp _ (List []) = return (List []) evalLisp eenv (Symbol ident) = getVar (eeE eenv) ident -- 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 eenv (List (Symbol "apply" : fn : args)) = do func <- evalLisp eenv fn argVals <- mapM (evalLisp eenv) args appp (func:argVals) where appp [f, List as] = apply eenv f as appp (f : as) = apply eenv f as appp _ = progError "evalLisp/apply" -- TODO: this is not a special form according to R6RS; the only reason -- I put it here is because evalLisp wants an environment, and that's -- 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 eenv (List (Symbol "eval" : args)) = mapM (evalPP eenv) args >>= mapM (evalLisp eenv) >>= mapML (evalLisp eenv) -- TODO: This is also not a special form according to R6RS; I think I -- could also make it a regular function, but it has the same issues -- 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 eenv (List [Symbol "load", arg]) = do fname <- evalLisp eenv arg if isStr fname then loadFile (getStr fname) >>= mapM (evalPP eenv) >>= mapML (evalLisp eenv) else throwError (Default ("bad load form: " ++ show fname ++ " is not a string")) evalLisp eenv (List (Symbol "begin" : args)) = mapML (evalLisp eenv) args evalLisp _ (List [Symbol "quote", val]) = return val evalLisp eenv (List [Symbol "quasiquote", val]) = evalQQ (eeQLIncr eenv) val >>= liftSUnq evalLisp _ (List (Symbol "unquote" : args)) = throwError (Default ("naked unquote form: " ++ show args)) evalLisp _ (List (Symbol "unquote-splicing" : args)) = throwError (Default ("naked unquote-splicing form: " ++ show args)) evalLisp eenv (List [Symbol "set!", Symbol var, val]) = evalLisp eenv val >>= setVar (eeE eenv) var evalLisp eenv (List [Symbol "vector-set!", Symbol var, indx, obj]) = do vec <- evalLisp eenv (Symbol var) if isVec vec then do lk <- evalLisp eenv indx let l = getVecL vec k = getInt lk if isInt lk && k >= 0 && k < l then do val <- evalLisp eenv obj setVar (eeE eenv) var (Vector l (DIM.insert (fromInteger k) val (getVecV vec))) else throwError (VectorBounds l lk) else throwError (Default ("bad vector-set! form: " ++ show var ++ " is not a vector")) evalLisp eenv (List [Symbol "vector-fill!", Symbol var, obj]) = do vec <- evalLisp eenv (Symbol var) if isVec vec then do val <- evalLisp eenv obj let n = getVecL vec setVar (eeE eenv) var (Vector n (DIM.fromAscList (addkey val (fromInteger n)))) else throwError (Default ("bad vector-fill! form: " ++ show var ++ " is not a vector")) where addkey _ 0 = [] addkey v n = ((n-1), v) : addkey v (n-1) evalLisp eenv (List [Symbol "vector-resize!", Symbol var, obj]) = do vec <- evalLisp eenv (Symbol var) if isVec vec then do lk <- evalLisp eenv obj let l = getVecL vec k = getInt lk if isInt lk && k > 0 then do let new = if k < l then rmv (getVecV vec) l k else add (getVecV vec) k l setVar (eeE eenv) 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 rmv vec h l = if h == l then vec else rmv (DIM.delete (fromInteger l) vec) h (l + 1) add vec h l = if h == l then vec else add (DIM.insert (fromInteger l) lispFalse vec) h (l + 1) evalLisp eenv (List [Symbol "define", Symbol var, val]) = do let env = eeE eenv defineVar env var lispFalse evalLisp eenv val >>= setVar env var evalLisp eenv (List [Symbol "define", Symbol var]) = defineVar (eeE eenv) var lispFalse evalLisp (EEnv env _ _ _) (List (Symbol "define" : List (Symbol var : params) : body)) = if paramsCheck params then do defineVar env var lispFalse makeNormalFunc env params body >>= setVar env var else errBadForm "define" params evalLisp (EEnv env _ _ _) (List (Symbol "define" : DottedList (Symbol var : params) varargs : body)) = if paramsCheck (params ++ [varargs]) then do defineVar env var lispFalse makeVarargsFunc varargs env params body >>= setVar env var else errBadForm "define" [DottedList params varargs] evalLisp (EEnv env _ _ _) (List (Symbol "defmacro" : List (Symbol var : params) : body)) = if paramsCheck params then do defineVar env var lispFalse makeNormalMacro env params body >>= setVar env var else errBadForm "defmacro" params evalLisp (EEnv env _ _ _) (List (Symbol "defmacro" : DottedList (Symbol var : params) varargs : body)) = if paramsCheck (params ++ [varargs]) then do defineVar env var lispFalse makeVarargsMacro varargs env params body >>= setVar env var else errBadForm "defmacro" [DottedList params varargs] evalLisp eenv (List (Symbol "lambda" : List params : body)) = if paramsCheck params then makeNormalFunc (eeE eenv) params body else errBadForm "lambda" params evalLisp eenv (List (Symbol "lambda" : DottedList params varargs : body)) = if paramsCheck (params ++ [varargs]) then makeVarargsFunc varargs (eeE eenv) params body else errBadForm "lambda" [DottedList params varargs] evalLisp eenv (List (Symbol "lambda" : varargs@(Symbol _) : body)) = makeVarargsFunc varargs (eeE eenv) [] body evalLisp eenv (List [Symbol "if", pr, tcase, fcase]) = do result <- evalLisp eenv pr case result of Boolean False -> evalLisp eenv fcase _ -> evalLisp eenv tcase evalLisp eenv (List [Symbol "if", pr, tcase]) = do result <- evalLisp eenv pr case result of Boolean False -> return lispFalse _ -> evalLisp eenv tcase evalLisp eenv (List (Symbol "and" : args)) = eva (eeE eenv) args lispTrue where eva _ [] ret = return ret eva env (t:ts) _ = do result <- evalLisp eenv t case result of Boolean False -> return lispFalse _ -> eva env ts result evalLisp eenv (List (Symbol "or" : args)) = evo (eeE eenv) args lispFalse where evo _ [] ret = return ret evo env (t:ts) _ = do result <- evalLisp eenv t case result of Boolean False -> evo env ts result _ -> return result evalLisp _ (List [Symbol "cond"]) = return lispFalse evalLisp eenv (List (Symbol "cond" : args)) = if all isList args then evc (eeE eenv) args else errTypeMismatch "cond" "cond-clauses" (String (show args)) where evc _ [] = return lispFalse evc env (cl:cls) = do (tst,val) <- evc_clause env cl if tst then return val else evc env cls evc_clause _ (List (Symbol "else" : as)) = do ret <- mapML (evalLisp eenv) as return (True, ret) evc_clause env (List (pr : as)) = do tst <- evalLisp eenv pr case tst of Boolean False -> return (False, lispFalse) _ -> do ret <- if isArrow as then evcArrow env as tst else mapML (evalLisp eenv) as return (True, ret) evc_clause _ _ = return (False, lispFalse) isArrow [Symbol "=>", _] = True isArrow _ = False evcArrow env [Symbol "=>", proc] val = let een = eeNewE eenv env in evalLisp een proc >>= flip (apply een) [val] evcArrow _ _ _ = progError "evalLisp/cond/evcArrow" evalLisp eenv (List (Symbol "let" : List params : body)) = if letCheck True params then do func <- makeNormalFunc (eeE eenv) (map exn params) body mapM (evalLisp eenv . exv) params >>= apply eenv func else errBadForm "let" params where exn (List [Symbol var, _]) = Symbol var exn _ = progError "evalLisp/let/exn1" exv (List [Symbol _, val]) = val exv _ = progError "evalLisp/let/exv1" evalLisp eenv (List (Symbol "let" : Symbol lname : List params : body)) = if letCheck True params then do envn <- liftIO (bindVars (eeE eenv) [(lname, lispFalse)]) func <- makeNormalFunc envn (map exn params) body setVar envn lname func mapM (evalLisp eenv . exv) params >>= apply eenv func else errBadForm "named-let" params where exn (List [Symbol var, _]) = Symbol var exn _ = progError "evalLisp/let/exn2" exv (List [Symbol _, val]) = val exv _ = progError "evalLisp/let/exv2" evalLisp eenv (List (Symbol "let*" : List params : body)) = if letCheck False params then dols params body (eeE eenv) else errBadForm "let*" params where dols [] b env = mapML (evalLisp (eeNewE eenv env)) b dols (p:ps) b env = do val <- evalLisp (eeNewE eenv env) (exv p) liftIO (bindVars env [(exn p, val)]) >>= dols ps b exn (List [Symbol var, _]) = var exn _ = progError "evalLisp/let*/exn" exv (List [Symbol _, val]) = val exv _ = progError "evalLisp/let*/exv" evalLisp eenv (List (Symbol "letrec" : List params : body)) = if letCheck True params then dolr params body (eeE eenv) else errBadForm "letrec" params where dolr ps b env = do let varn = map exn ps envn <- liftIO (bindVars env varn) let een = eeNewE eenv envn varv <- mapM (evalLisp een . exv) ps mapM_ (doSet envn) (repl varn varv) >> mapML (evalLisp een) b exn (List [Symbol var, _]) = (var, lispFalse) exn _ = progError "evalLisp/letrec/exn" exv (List [Symbol _, val]) = val exv _ = progError "evalLisp/letrec/exv" repl [] [] = [] -- TODO: fix this! it's infelicitous... would prefer to not know -- what lispFalse looks like on the inside repl ((n, Boolean False):ns) (v:vs) = (n, v) : repl ns vs repl _ _ = progError "evalLisp/letrec/repl" doSet env (n,v) = setVar env n v evalLisp eenv (List (Symbol "letrec*" : List params : body)) = if letCheck False params then dolr params body (eeE eenv) else errBadForm "letrec*" params where dolr ps b env = do let varn = map exn ps envn <- liftIO (bindVars env varn) mapM_ (evSet envn) ps >> mapML (evalLisp (eeNewE eenv envn)) b exn (List [Symbol var, _]) = (var, lispFalse) exn _ = progError "evalLisp/letrec*/exn" evSet env (List [Symbol var, val]) = evalLisp (eeNewE eenv env) val >>= setVar env var evSet _ _ = progError "evalLisp/letrec*/evSet" evalLisp _ (List [Symbol "case"]) = return lispFalse evalLisp eenv (List (Symbol "case" : k : as)) = if null as || not (all isLL as) then errTypeMismatch "case" "case-clauses" (String (show as)) else evalLisp eenv k >>= evc (eeE eenv) as where isLL (List (List _ : _)) = True isLL (List (Symbol "else" : _)) = True isLL _ = False evc _ [] _ = return lispFalse evc env (cl:cls) k1 = do (tst,val) <- evc_clause env cl k1 if tst then return val else evc env cls k1 evc_clause env (List (Symbol "else" : args)) _ = do ret <- mapML (evalLisp (eeNewE eenv env)) args return (True, ret) evc_clause env (List (List vals : args)) k1 = if valMatch k1 vals then do ret <- mapML (evalLisp (eeNewE eenv env)) args return (True, ret) else return (False, lispFalse) evc_clause _ _ _ = return (False, lispFalse) valMatch k1 (v:vs) = Library.eqv [k1, v] || valMatch k1 vs valMatch _ [] = False evalLisp eenv (List (Symbol "guard" : List (Symbol var : clauses) : body)) = if all isList clauses then catchError (mapML (evalLisp eenv) body) (\err -> do let errval = unpackErr err liftIO (bindVars (eeE eenv) [(var, errval)]) >>= evc err clauses) else errTypeMismatch "guard" "error-clauses" (String (show clauses)) where unpackErr (UserException val) = val unpackErr err = String (show err) evc err [] _ = throwError err evc err (cl:cls) env = do (tst,val) <- evc_clause env cl if tst then return val else evc err cls env evc_clause env (List (Symbol "else" : args)) = do ret <- mapML (evalLisp (eeNewE eenv env)) args return (True, ret) evc_clause env (List (pr : args)) = do let een = eeNewE eenv env tst <- evalLisp een pr case tst of Boolean False -> return (False, lispFalse) _ -> do ret <- if isArrow args then evcArrow env args tst else mapML (evalLisp een) args return (True, ret) evc_clause _ _ = return (False, lispFalse) isArrow [Symbol "=>", _] = True isArrow _ = False evcArrow env [Symbol "=>", proc] val = let een = eeNewE eenv env in evalLisp een proc >>= flip (apply een) [val] evcArrow _ _ _ = progError "evalLisp/guard/evcArrow" -- This creates an internal variable for each delay object where its value -- will be stored once it is forced. We avoid collisions with any symbols -- 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 eenv (List [Symbol "delay", val]) = do let env = eeE eenv dval <- getVar env delayCounter let count = getInt dval do setVar env delayCounter (IntNumber (count + 1)) return (Delay val env (" delay." ++ show count)) evalLisp eenv (List [Symbol "force", val]) = do vali <- evalLisp eenv val if isDelay vali then do let (env, tag) = getTag vali alreadyDef <- liftIO (isBound env tag) 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) getTag _ = progError "evalLisp/getTag" forceEval (Delay obj env _) = evalLisp (eeNewE eenv env) obj forceEval _ = progError "evalLisp/forceEval" evalLisp eenv (List (Symbol "do" : List params : List test : body)) = if doCheck params then do let names = map exn params steps = map exs params inits <- mapM (evalLisp eenv . exi) params envn <- liftIO (bindVars (eeE eenv) (zip names inits)) doloop envn names test steps else errBadForm "do" params where exn (List [Symbol var, _]) = var exn (List [Symbol var, _, _]) = var exn _ = progError "evalLisp/do/exn" exi (List [Symbol _, ini]) = ini exi (List [Symbol _, ini, _]) = ini exi _ = progError "evalLisp/do/exi" exs (List [Symbol var, _]) = Symbol var exs (List [Symbol _, _, step]) = step exs _ = progError "evalLisp/do/exs" doSet env (n,v) = setVar env n v doloop env names (tst:rets) steps = do let een = eeNewE eenv env tval <- evalLisp een tst if isTrue tval then mapML (evalLisp een) rets else do mapM_ (evalLisp een) body svals <- mapM (evalLisp een) steps mapM_ (doSet env) (zip names svals) doloop env names (tst:rets) steps doloop _ _ [] _ = progError "evalLisp/do/doloop" -- This creates a new guaranteed-never-before-used symbol (and one which -- the user can't enter, so guaranteed no past present or future clashes). evalLisp (EEnv env _ _ _) (List [Symbol "gensym"]) = do sval <- getVar env symbolCounter let count = getInt sval do setVar env symbolCounter (IntNumber (count + 1)) return (Symbol (" symbol." ++ show count)) -- Delimited continuations -- two new special forms: (reset expr ...) -- and (shift id fname expr ...) which is the translation of shift -- NOTE! 'shift ' is a single symbol, with a space at the end; this makes it -- harder for the user to enter it directly (but not impossible: generate a -- quoted expression like '(reset (shift f #t)), then take the result apart -- to get the desired symbols... if you do this, you deserve what you get). evalLisp eenv@(EEnv _ _ dcs _) (List (Symbol "reset" : as)) = catchError (mapML (evalLisp (eeNewDC eenv (as:dcs))) as) getVal where getVal (DelCont val) = return val getVal err = throwError err evalLisp (EEnv _ _ [] _) a@(List (Symbol "shift " : Symbol _ : Symbol _ : _)) = throwError (BadSpecial "naked internal delcont form" a) -- TODO: does the isCont test need to be made more discriminating? -- check if it could perhaps fail with nested or multiple calls to the -- continuation function evalLisp eenv (List (Symbol "shift " : Symbol cid : Symbol fn : as)) = do let env = eeE eenv isCont = lookup cid (eePE eenv) case isCont of Just val -> return val Nothing -> do let cbody = [List (Symbol "reset" : head (eeDC eenv))] ebody = [List (Symbol "reset" : as)] func <- makeContFunc env [Symbol cid] cbody envn <- liftIO (bindVars env [(fn, func)]) mapML (evalLisp (eeNewE eenv envn)) ebody >>= throwError . DelCont {- if isCont then (getVar env cid) >>= return else do let cbody = [List ([Symbol "reset"] ++ (head (eeDC eenv)))] ebody = [List ([Symbol "reset"] ++ as)] func <- makeContFunc env [Symbol cid] cbody envn <- liftIO (bindVars env [(fn, func)]) mapML (evalLisp (eeNewE eenv envn)) ebody >>= throwError . DelCont -} -- This is not an R6RS special form, but it is a haskeem one: it needs -- to be, because we don't want to evaluate the function name, and we -- 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 eenv (List [Symbol "trace", Symbol var, sw]) = if isSpecialForm (Symbol var) then throwError (Default "can't trace special forms") else do val <- evalLisp eenv (Symbol var) swval <- evalLisp eenv sw let env = eeE eenv if isPr val then throwError (Default "can't trace primitives") else if isF val -- 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 cont) = Func params varargs body closure (Just name) mac cont trOn _ _ = progError "evalLisp/trace/trOn" trOff (Func params varargs body closure _ mac cont) = Func params varargs body closure Nothing mac cont trOff _ = progError "evalLisp/trace/trOff" -- This is also not an R6RS special form, but a haskeem one: it needs -- to be, because we want the ability to show the current environment -- rather than just the top-level one evalLisp eenv (List [Symbol "dump-bindings"]) = dumpEnv (eeE eenv) stderr [] evalLisp eenv (List [Symbol "dump-bindings", val]) = do vali <- evalLisp eenv val if isPort vali then dumpEnv (eeE eenv) (getPort vali) [] else errBadForm "dump-bindings" [val] where isPort (Port _) = True isPort _ = False getPort (Port p) = p getPort _ = progError "evalLisp/dump-bindings" -- The generic (function : as) stuff; also macro expansion stuff -- For macro expansion, we evaluate once to get syntax back from the -- macro, that's the "evalLisp env dcs ql function", but then we change -- the environment to evaluate that syntax in the caller's environment. evalLisp eenv (List (function : as)) = if isSpecialForm function then throwError (BadSpecial "bad syntax for special form" function) else do func <- evalLisp eenv function if isM func then apply eenv (chEnv func (eeE eenv)) as >>= prtTrace (isT func) >>= evalPP eenv >>= evalLisp eenv else mapM (evalLisp eenv) as >>= apply eenv func where isM (Func _ _ _ _ _ mac _) = mac isM _ = False isT (Func _ _ _ _ (Just _) _ _) = True isT _ = False chEnv (Func pars vars bod _ name mac cont) envn = Func pars vars bod envn name mac cont chEnv _ _ = progError "evalLisp/generic-function" prtTrace trace vals = if trace then remark (" -> " ++ show vals) >> return vals else return vals evalLisp _ badForm = throwError (BadSpecial "Unrecognized special form" badForm)