haskeem-0.7.12: Evaluator.hs
{- 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 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)