haskeem-0.7.0: 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 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.27 2009-06-06 20:40:08 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!"

lastOrNil = liftM lON
  where lON [] = List []
        lON l = last l

isTrue :: LispVal -> Bool
isTrue (Bool 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 = lastOrNil (mapM (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) args =
  doApply False "" params varargs body closure ql args
apply ql (Macro params varargs body closure) args =
  doApply False "" params varargs body closure ql args
apply ql (TraceFunc name params varargs body closure) 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)
makeNormalFunc = makeFunc Nothing
makeVarargsFunc = makeFunc . Just . show

makeMacro varargs env params body =
  return (Macro (map show params) varargs body env)
makeNormalMacro = makeMacro Nothing
makeVarargsMacro = makeMacro . Just . show

isSpecialForm :: LispVal -> Bool
isSpecialForm (Symbol "and") = True
isSpecialForm (Symbol "apply") = True
isSpecialForm (Symbol "begin") = True
isSpecialForm (Symbol "case") = True
isSpecialForm (Symbol "cond") = True
isSpecialForm (Symbol "define") = True
isSpecialForm (Symbol "defmacro") = True
isSpecialForm (Symbol "delay") = True
isSpecialForm (Symbol "do") = True
isSpecialForm (Symbol "eval") = True
isSpecialForm (Symbol "force") = True
isSpecialForm (Symbol "guard") = True
isSpecialForm (Symbol "if") = True
isSpecialForm (Symbol "lambda") = True
isSpecialForm (Symbol "let") = True
isSpecialForm (Symbol "let*") = True
isSpecialForm (Symbol "letrec") = True
isSpecialForm (Symbol "letrec*") = True
isSpecialForm (Symbol "load") = True
isSpecialForm (Symbol "new-symbol") = True
isSpecialForm (Symbol "or") = True
isSpecialForm (Symbol "quasiquote") = True
isSpecialForm (Symbol "quote") = True
isSpecialForm (Symbol "set!") = True
isSpecialForm (Symbol "unless") = True
isSpecialForm (Symbol "unquote") = True
isSpecialForm (Symbol "unquote-splicing") = True
isSpecialForm (Symbol "vector-fill!") = True
isSpecialForm (Symbol "vector-set!") = True
isSpecialForm (Symbol "when") = True

isSpecialForm (Symbol "trace") = True
isSpecialForm (Symbol "dump-bindings") = True
isSpecialForm _ = False

-- 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 isList 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 isList [] = True
        isList ((List _):ls) = isList ls
        isList _ = 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 isl vcab
        then return (List (head ++ (unpl vcab)))
        else if isdl vcab
                then return (DottedList (head ++ (unpdlh vcab)) (unpdlt vcab))
                else return (DottedList head vcab)
  where isl (List _) = True
        isl _ = False
        unpl (List l) = l
        isdl (DottedList _ _) = True
        isdl _ = False
        unpdlh (DottedList h _) = h
        unpdlt (DottedList _ t) = t

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@(Bool _) = 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)) =
  do argVals <- mapM (evalLisp env ql) args
     lastOrNil (mapM (evalLisp env ql) argVals)

-- 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 >>= lastOrNil . mapM (evalLisp env ql)

evalLisp env ql (List (Symbol "begin" : args)) =
  lastOrNil (mapM (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 = getL vec
                    k = getI lk
                if ((isI lk) && k >= 0 && k < l)
                   then do val <- evalLisp env ql obj
                           setVar env var (Vector l
                             (DIM.insert (fromInteger k) val (getV vec)))
                   else throwError (VectorBounds l lk)
        else throwError (Default ("bad vector-set! form: " ++
                                  (show var) ++ " is not a vector"))
  where isVec (Vector _ _) = True
        isVec _ = False
        isI (IntNumber _) = True
        isI _ = False
        getI (IntNumber n) = n
        getL (Vector l _) = l
        getV (Vector _ v) = v

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 = getL 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 isVec (Vector _ _) = True
        isVec _ = False
        getL (Vector l _) = l
        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 = getL vec
                    k = getI lk
                if (isI lk) && (k > 0)
                   then do let new = if k < l
                                        then rem (getV vec) l k
                                        else add (getV 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 isVec (Vector _ _) = True
        isVec _ = False
        getL (Vector l _) = l
        getV (Vector _ v) = v
        isI (IntNumber _) = True
        isI _ = False
        getI (IntNumber n) = n
        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) (Bool False) vec) h (l + 1)

evalLisp env ql (List [Symbol "define", Symbol var, val]) =
  do defineVar env var (Bool False)
     evalLisp env ql val >>= setVar env var
evalLisp env _ (List [Symbol "define", Symbol var]) =
  defineVar env var (Bool False)
evalLisp env _ (List (Symbol "define" : List (Symbol var : params) : body)) =
  if paramsCheck params
     then do defineVar env var (Bool False)
             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 (Bool False)
             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 (Bool False)
             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 (Bool False)
             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
          Bool 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
          Bool False -> return (Bool False)
          _ -> evalLisp env ql tcase

evalLisp env ql (List (Symbol "when" : pred : docase)) =
  do result <- evalLisp env ql pred
     case result of
          Bool False -> return (Bool False)
          _ -> lastOrNil (mapM (evalLisp env ql) docase)

evalLisp env ql (List (Symbol "unless" : pred : docase)) =
  do result <- evalLisp env ql pred
     case result of
          Bool False -> lastOrNil (mapM (evalLisp env ql) docase)
          _ -> return (Bool False)

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

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

evalLisp _ _ (List [Symbol "cond"]) = return (Bool False)
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 isList (List _) = True
        isList _ = False
        evc _ [] = return (Bool False)
        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 <- lastOrNil (mapM (evalLisp env ql) args)
             return (True, ret)
        evc_clause env (List (pred : args)) =
          do tst <- evalLisp env ql pred
             case tst of
                  Bool False -> return (False, (Bool False))
                  _ -> do ret <- if isArrow args
                                    then evcArrow env args tst
                                    else lastOrNil
                                          (mapM (evalLisp env ql) args)
                          return (True, ret)
        evc_clause _ _ = return (False, (Bool False))
        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, Bool False)])
             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 = lastOrNil (mapM (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) >>
                  lastOrNil (mapM (evalLisp envn ql) body)
        exn (List [Symbol var, _]) = (var, Bool False)
        exv (List [Symbol _, val]) = val
        repl [] [] = []
        repl ((n, Bool False):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 >>
                  lastOrNil (mapM (evalLisp envn ql) body)
        exn (List [Symbol var, _]) = (var, Bool False)
        evSet env (List [Symbol var, val]) =
              evalLisp env ql val >>= setVar env var

evalLisp _ _ (List [Symbol "case"]) = return (Bool False)
evalLisp env ql (List (Symbol "case" : key : args)) =
  if (isNull args) || (foldl1 (&&) (map isList args) == False)
     then errTypeMismatch "case" "case-clauses" (String (show args))
     else evalLisp env ql key >>= evc env args
  where isNull [] = True
        isNull _ = False
        isList (List (List _ : _)) = True
        isList (List (Symbol "else" : _)) = True
        isList _ = False
        evc _ [] _ = return (Bool False)
        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 <- lastOrNil (mapM (evalLisp env ql) args)
             return (True, ret)
        evc_clause env (List (List vals : args)) key =
          if valMatch key vals
             then do ret <- lastOrNil (mapM (evalLisp env ql) args)
                     return (True, ret)
             else return (False, (Bool False))
        evc_clause _ _ _ = return (False, (Bool False))
        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 (lastOrNil (mapM (evalLisp env ql) body))
                     (\err -> do let errval = unpackErr err
                                 liftIO (bindVars env [(var, errval)]) >>=
                                   evc err clauses)
  where isList (List _) = True
        isList _ = False
        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 <- lastOrNil (mapM (evalLisp env ql) args)
             return (True, ret)
        evc_clause env (List (pred : args)) =
          do tst <- evalLisp env ql pred
             case tst of
                  Bool False -> return (False, (Bool False))
                  _ -> do ret <- if isArrow args
                                    then evcArrow env args tst
                                    else lastOrNil
                                          (mapM (evalLisp env ql) args)
                          return (True, ret)
        evc_clause _ _ = return (False, (Bool False))
        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 = getCount dval
     do setVar env delayCounter (IntNumber (count + 1))
        return (Delay val env (" delay." ++ (show count)))
  where getCount (IntNumber n) = n

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 do lastOrNil (mapM (evalLisp env ql) rets) >>= return
                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 "new-symbol"]) =
  do sval <- getVar env symbolCounter
     let count = getCount sval
     do setVar env symbolCounter (IntNumber (count + 1))
        return (Symbol (" symbol." ++ (show count)))
  where getCount (IntNumber n) = n
        getCount _ = progError

-- 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.

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 (isNF val) && (isTrue swval)
                        then (remark ("trace " ++ var ++ " on")) >>
                             setVar env var (trOn var val) >>
                             return (Bool True)
                        else if (isTF val) && (not (isTrue swval))
                                then (remark ("trace " ++ var ++ " off")) >>
                                     setVar env var (trOff val) >>
                                     return (Bool True)
                                else errBadForm "trace" ((Symbol var):[sw])
  where isPr (Prim _) = True
        isPr (IOPrim _) = True
        isPr _ = False
        isNF (Func _ _ _ _) = True
        isNF _ = False
        isTF (TraceFunc _ _ _ _ _) = True
        isTF _ = False
        trOn name (Func params varargs body closure) =
              (TraceFunc name params varargs body closure)
        trOn _ _ = progError
        trOff (TraceFunc _ params varargs body closure) =
              (Func params varargs body closure)
        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

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 func args >>= evalLisp env ql
                else mapM (evalLisp env ql) args >>= apply ql func
  where isM (Macro _ _ _ _) = True
        isM _ = False

evalLisp _ _ badForm =
  throwError (BadSpecial "Unrecognized special form" badForm)