{- Copyright 2008 Uwe Hollerbach <uh@alumni.caltech.edu>
Portions of this were derived from Jonathan Tang's haskell
tutorial "Write yourself a scheme in 48 hours" and are thus
Copyright Jonathan Tang
(but I can't easily tell anymore who originally wrote what)

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.35 2009-07-04 07:47:22 uwe Exp $ -}

module Evaluator (evalLisp) 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 -> Integer -> [LispVal] -> IOThrowsError LispVal
doApply trace name params varargs body closure 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 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 :: Integer -> LispVal -> [LispVal] -> IOThrowsError LispVal
apply _ (Prim func) args = liftThrows (func args)
apply _ (IOPrim func) args = func args
apply ql (Func params varargs body closure Nothing _) args =
  doApply False "" params varargs body closure ql args
apply ql (Func params varargs body closure (Just name) _) args =
  doApply True name params varargs body closure ql args
apply _ func _ = throwError (NotFunction "apply got non-function" func)

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!", "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 -> Integer -> LispVal -> IOThrowsError LispVal

-- "quasiquote", "unquote", and "unquote-splicing" might get evaluated,
-- depending on quote level

evalQQ env ql (List [Symbol "quasiquote", arg]) =
  do val <- evalQQ env (ql + 1) arg >>= liftSUnq
     return (List [Symbol "quasiquote", val])

evalQQ env ql (List (Symbol "unquote" : args)) =
  if ql == 1
     then do vals <- mapM (evalLisp env 0) args
             return (List ((Symbol unq):vals))
     else do vals <- mapM (evalQQ env (ql - 1)) args
             return (List ((Symbol "unquote") : (liftLUnq vals)))

evalQQ env ql (List (Symbol "unquote-splicing" : args)) =
  if ql == 1
     then do vals <- mapM (evalLisp env 0) args
             if isLL vals
                then return (List ((Symbol unq):(peel vals)))
                else throwError (Default ("bad unquote-splicing form: " ++
                                (show args)))
     else do vals <- mapM (evalQQ env (ql - 1)) args
             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 ql (List con) =
  mapM (evalQQ env ql) con >>= return . List . liftLUnq

evalQQ env ql (DottedList con cab) =
  do vals <- mapM (evalQQ env ql) con
     vcab <- evalQQ env 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 ql (Vector _ con) =
  do vals <- mapM (evalQQ env 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

-- This is the main evaluator

evalLisp :: Env -> 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 ql (List (Symbol "apply" : function : args)) =
  do func <- evalLisp env ql function
     argVals <- mapM (evalLisp env ql) args
     appp ql (func:argVals)
  where appp ql [func, List args] = apply ql func args
        appp ql (func : args) = apply ql func args

-- 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 ql (List (Symbol "eval" : args)) =
  mapM (evalLisp env ql) args >>= mapML (evalLisp env 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 ql (List [Symbol "load", String filename]) =
  loadFile filename >>= mapML (evalLisp env ql)
evalLisp env ql (List [Symbol "load", arg]) =
  do fname <- evalLisp env ql arg
     if isStr fname
        then loadFile (getStr fname) >>= mapML (evalLisp env ql)
        else throwError (Default ("bad load form: " ++
                                  (show fname) ++ " is not a string"))

evalLisp env ql (List (Symbol "begin" : args)) =
  mapML (evalLisp env ql) args

evalLisp _ _ (List [Symbol "quote", val]) = return val

evalLisp env ql (List [Symbol "quasiquote", val]) =
  evalQQ env (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 ql (List [Symbol "set!", Symbol var, val]) =
  evalLisp env ql val >>= setVar env var

evalLisp env ql (List [Symbol "vector-set!", Symbol var, indx, obj]) =
  do vec <- evalLisp env ql (Symbol var)
     if isVec vec
        then do lk <- evalLisp env ql indx
                let l = getVecL vec
                    k = getInt lk
                if ((isInt lk) && k >= 0 && k < l)
                   then do val <- evalLisp env ql obj
                           setVar env var (Vector l
                             (DIM.insert (fromInteger k) val (getVecV vec)))
                   else throwError (VectorBounds l lk)
        else throwError (Default ("bad vector-set! form: " ++
                                  (show var) ++ " is not a vector"))

evalLisp env ql (List [Symbol "vector-fill!", Symbol var, obj]) =
  do vec <- evalLisp env ql (Symbol var)
     if isVec vec
        then do val <- evalLisp env 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 ql (List [Symbol "vector-resize!", Symbol var, obj]) =
  do vec <- evalLisp env ql (Symbol var)
     if isVec vec
        then do lk <- evalLisp env 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 ql (List [Symbol "define", Symbol var, val]) =
  do defineVar env var lispFalse
     evalLisp env ql val >>= setVar env var
evalLisp env _ (List [Symbol "define", Symbol var]) =
  defineVar env var lispFalse
evalLisp env _ (List (Symbol "define" : List (Symbol var : params) : body)) =
  if paramsCheck params
     then do defineVar env var lispFalse
             makeNormalFunc env params body >>= setVar env var
     else errBadForm "define" params
evalLisp env _ (List (Symbol "define" :
              DottedList (Symbol var : params) varargs : body)) =
  if paramsCheck (params ++ [varargs])
     then do defineVar env var lispFalse
             makeVarargsFunc varargs env params body >>= setVar env var
     else errBadForm "define" [DottedList params varargs]

evalLisp env _ (List (Symbol "defmacro" : List (Symbol var : params) : body)) =
  if paramsCheck params
     then do defineVar env var lispFalse
             makeNormalMacro env params body >>= setVar env var
     else errBadForm "defmacro" params
evalLisp env _ (List (Symbol "defmacro" :
              DottedList (Symbol var : params) varargs : body)) =
  if paramsCheck (params ++ [varargs])
     then do defineVar env var lispFalse
             makeVarargsMacro varargs env params body >>= setVar env var
     else errBadForm "defmacro" [DottedList params varargs]

evalLisp env _ (List (Symbol "lambda" : List params : body)) =
  if paramsCheck params
     then makeNormalFunc env params body
     else errBadForm "lambda" params
evalLisp env _ (List (Symbol "lambda" : DottedList params varargs : body)) =
  if paramsCheck (params ++ [varargs])
     then makeVarargsFunc varargs env params body
     else errBadForm "lambda" [DottedList params varargs]
evalLisp env _ (List (Symbol "lambda" : varargs@(Symbol _) : body)) =
  makeVarargsFunc varargs env [] body

evalLisp env ql (List [Symbol "if", pred, tcase, fcase]) =
  do result <- evalLisp env ql pred
     case result of
          Boolean False -> evalLisp env ql fcase
          _ -> evalLisp env ql tcase
evalLisp env ql (List [Symbol "if", pred, tcase]) =
  do result <- evalLisp env ql pred
     case result of
          Boolean False -> return lispFalse
          _ -> evalLisp env ql tcase

evalLisp env ql (List (Symbol "and" : args)) = eva env args lispTrue
  where eva _ [] ret = return ret
        eva env (t:ts) _ =
          do result <- evalLisp env ql t
             case result of
                  Boolean False -> return lispFalse
                  _ -> eva env ts result

evalLisp env ql (List (Symbol "or" : args)) = evo env args lispFalse
  where evo _ [] ret = return ret
        evo env (t:ts) _ =
          do result <- evalLisp env ql t
             case result of
                  Boolean False -> evo env ts result
                  _ -> return result

evalLisp _ _ (List [Symbol "cond"]) = return lispFalse
evalLisp env ql (List (Symbol "cond" : args)) =
  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 ql) args
             return (True, ret)
        evc_clause env (List (pred : args)) =
          do tst <- evalLisp env ql pred
             case tst of
                  Boolean False -> return (False, lispFalse)
                  _ -> do ret <- if isArrow args
                                    then evcArrow env args tst
                                    else mapML (evalLisp env ql) args
                          return (True, ret)
        evc_clause _ _ = return (False, lispFalse)
        isArrow [Symbol "=>", _] = True
        isArrow _ = False
        evcArrow env [Symbol "=>", proc] val =
          evalLisp env ql proc >>= (flip (apply ql)) [val]

evalLisp env ql (List (Symbol "let" : List params : body)) =
  if letCheck True params
     then do func <- makeNormalFunc env (map exn params) body
             argVals <- mapM (evalLisp env ql) (map exv params)
             apply ql func argVals
     else errBadForm "let" params
    where exn (List [Symbol var, _]) = Symbol var
          exv (List [Symbol _, val]) = val

evalLisp env ql (List (Symbol "let" : Symbol lname : List params : body)) =
  if letCheck True params
     then do envn <- liftIO (bindVars env [(lname, lispFalse)])
             func <- makeNormalFunc envn (map exn params) body
             setVar envn lname func
             argVals <- mapM (evalLisp env ql) (map exv params)
             apply ql func argVals
     else errBadForm "named-let" params
    where exn (List [Symbol var, _]) = Symbol var
          exv (List [Symbol _, val]) = val

evalLisp env ql (List (Symbol "let*" : List params : body)) =
  if letCheck False params
     then dols params body env
     else errBadForm "let*" params
  where dols [] body env = mapML (evalLisp env ql) body
        dols (p:ps) body env =
             do val <- evalLisp env ql (exv p)
                (liftIO (bindVars env [(exn p, val)])) >>= (dols ps body)
        exn (List [Symbol var, _]) = var
        exv (List [Symbol _, val]) = val

evalLisp env ql (List (Symbol "letrec" : List params : body)) =
  if letCheck True params
     then dolr params body env
     else errBadForm "letrec" params
  where dolr params body env =
          do let varn = map exn params
             envn <- liftIO (bindVars env varn)
             varv <- mapM (evalLisp envn ql) (map exv params)
             mapM (doSet envn) (repl varn varv) >>
                  mapML (evalLisp envn ql) body
        exn (List [Symbol var, _]) = (var, lispFalse)
        exv (List [Symbol _, val]) = val
        repl [] [] = []
        repl ((n, lispFalse):ns) (v:vs) = (n, v):(repl ns vs)
        doSet env (n,v) = setVar env n v

evalLisp env ql (List (Symbol "letrec*" : List params : body)) =
  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 ql) body
        exn (List [Symbol var, _]) = (var, lispFalse)
        evSet env (List [Symbol var, val]) =
              evalLisp env ql val >>= setVar env var

evalLisp _ _ (List [Symbol "case"]) = return lispFalse
evalLisp env ql (List (Symbol "case" : key : args)) =
  if (isNull args) || (foldl1 (&&) (map isLL args) == False)
     then errTypeMismatch "case" "case-clauses" (String (show args))
     else evalLisp env ql key >>= evc env args
  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 ql) args
             return (True, ret)
        evc_clause env (List (List vals : args)) key =
          if valMatch key vals
             then do ret <- mapML (evalLisp env ql) args
                     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 ql (List (Symbol "guard" : List (Symbol var : clauses) : body)) =
  if foldl (&&) True (map isList clauses) == False
     then errTypeMismatch "guard" "error-clauses" (String (show clauses))
     else catchError (mapML (evalLisp env ql) body)
                     (\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 ql) args
             return (True, ret)
        evc_clause env (List (pred : args)) =
          do tst <- evalLisp env ql pred
             case tst of
                  Boolean False -> return (False, lispFalse)
                  _ -> do ret <- if isArrow args
                                    then evcArrow env args tst
                                    else mapML (evalLisp env ql) args
                          return (True, ret)
        evc_clause _ _ = return (False, lispFalse)
        isArrow [Symbol "=>", _] = True
        isArrow _ = False
        evcArrow env [Symbol "=>", proc] val =
          evalLisp env ql proc >>= (flip (apply ql)) [val]

-- 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 ql (List [Symbol "force", val]) =
  do vali <- evalLisp envc 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 ql obj

evalLisp env ql (List (Symbol "do" : List params : List test : body)) =
  if doCheck params
     then do let names = map exn params
                 steps = map exs params
             inits <- mapM (evalLisp env ql) (map exi params)
             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 ql test
             if isTrue tval
                then mapML (evalLisp env ql) rets
                else do mapM (evalLisp env ql) body
                        svals <- mapM (evalLisp env 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)))

-- 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 ql (List [Symbol "trace", Symbol var, sw]) =
  if isSpecialForm (Symbol var)
     then throwError (Default "can't trace special forms")
     else do val <- evalLisp env ql (Symbol var)
             swval <- evalLisp env ql sw
             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 ql (List [Symbol "dump-bindings", val]) =
  do vali <- evalLisp env 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 ql function", but then we change
-- the environment to evaluate that syntax in the caller's environment.

evalLisp env ql (List (function : args)) =
  if isSpecialForm function
     then throwError (BadSpecial "bad syntax for special form" function)
     else do func <- evalLisp env ql function
             if isM func
                then apply ql (chEnv func env) args >>=
                     prtTrace (isT func) >>=
                     evalLisp env ql
                else mapM (evalLisp env ql) args >>= apply 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)