content: {-# LANGUAGE FlexibleContexts #-}
  {- |
  Module      : Language.Scheme.Compiler
  Copyright   : Justin Ethier
  Licence     : MIT (see LICENSE in the distribution)
  
  Maintainer  : github.com/justinethier
  Stability   : experimental
  Portability : portable
  
  This module contains a Scheme to Haskell compiler which performs the following 
  transformations:
  
  > Scheme AST (LispVal) => Haskell AST (HaskAST) => Compiled Code (String)
  
  The GHC compiler is then used to create a native executable. At present, the 
  focus has just been on creating a compiler that will generate correct, working 
  code. Many optimizations could and need to be made for time and space...
  
  Note the following type is used for all functions generated by the compiler: 
  
  > compiledFunc :: 
  >   Env ->                  -- Runtime Environment
  >   LispVal ->              -- Continuation
  >   LispVal ->              -- Value
  >   Maybe [LispVal] ->      -- Additional arguments
  >   IOThrowsError LispVal   -- Result
  
  -}
  
  module Language.Scheme.Compiler 
      (
        compile
      , compileApply
      , compileBlock
      , compileDivertedVars 
      , compileExpr
      , compileLambdaList
      , compileLisp
      , compileScalar
      , compileSpecialForm
      , compileSpecialFormBody
      , compileSpecialFormEntryPoint
      , defineLambdaVars
      , defineTopLevelVars
      , divertVars 
      , initializeCompiler
      , isPrim
      , mcompile
      , mfunc
      )
  where 
  import Language.Scheme.Compiler.Libraries as LSCL
  import Language.Scheme.Compiler.Types
  import qualified Language.Scheme.Core as LSC 
      (apply, evalLisp, findFileOrLib)
  import qualified Language.Scheme.Macro
  import Language.Scheme.Primitives
  import Language.Scheme.Types
  import Language.Scheme.Variables
  import Control.Monad.Except
  import qualified Data.List
  import Data.Maybe (fromMaybe)
  
  -- |Perform one-time initialization of the compiler's environment
  initializeCompiler :: Env -> IOThrowsError [HaskAST]
  initializeCompiler env = do
    -- Define imports var here as an empty list.
    -- This list is appended to by (load-ffi) instances,
    -- and the imports are explicitly added later on...
    _ <- defineNamespacedVar env 't' {-"internal"-} "imports" $ List []
    return []
  
  -- | Compile a file containing scheme code
  compileLisp 
      :: Env  -- ^ Compiler environment 
      -> String -- ^ Filename
      -> String -- ^ Function entry point (code calls into this function)
      -> Maybe String -- ^ Function exit point, if any
      -> IOThrowsError [HaskAST]
  compileLisp env filename entryPoint exitPoint = do
      filename' <- LSC.findFileOrLib filename 
      ast <- load filename' >>= compileBlock entryPoint exitPoint env []
      case ast of
          [] -> compileScalar 
                  " return $ Number 0" $ 
                  CompileOptions entryPoint False False exitPoint
          _ -> return ast
  
  -- |Compile a list (block) of Scheme code
  compileBlock :: String -> Maybe String -> Env -> [HaskAST] -> [LispVal] 
               -> IOThrowsError [HaskAST]
  compileBlock symThisFunc symLastFunc env result lisps = do
    _ <- defineTopLevelVars env lisps
    _compileBlock symThisFunc symLastFunc env result lisps
  
  _compileBlock :: String -> Maybe String -> Env -> [HaskAST] -> [LispVal]
                -> IOThrowsError [HaskAST]
  _compileBlock symThisFunc symLastFunc env result [c] = do
    let copts = CompileOptions symThisFunc False False symLastFunc 
    compiled <- mcompile env c copts
    case compiled of
      [val@(AstValue _)] -> do
        comp <- compileScalar' val copts
        _compileBlockDo return result comp
      [val@(AstRef _)] -> do
        comp <- compileScalar' val copts
        _compileBlockDo return result comp
      _ -> _compileBlockDo return result compiled
  -- A special case to splice in definitions from a (begin)
  _compileBlock symThisFunc symLastFunc env result 
      (c@(List [Atom "%husk-switch-to-parent-environment"]) : cs) = do
    let parEnv = fromMaybe env (parentEnv env)
    _ <- defineTopLevelVars parEnv cs
    Atom symNextFunc <- _gensym "f"
    compiled <- mcompile env c $ 
                         CompileOptions symThisFunc False False (Just symNextFunc)
    _compileBlockDo 
      (\ result' ->
           _compileBlock 
             (if isSingleValue compiled
                then symThisFunc 
                else symNextFunc)
              symLastFunc 
              parEnv result' cs)
      result
      compiled
  _compileBlock symThisFunc symLastFunc env result (c:cs) = do
    Atom symNextFunc <- _gensym "f"
    compiled <- mcompile env c $ 
                         CompileOptions symThisFunc False False (Just symNextFunc)
    _compileBlockDo
      (\ result' -> 
          _compileBlock 
             (if isSingleValue compiled
                then symThisFunc 
                else symNextFunc)
             symLastFunc 
             env result' cs)
      result
      compiled
  _compileBlock _ _ _ result [] = return result
  
  _compileBlockDo :: ([HaskAST] -> IOThrowsError [HaskAST]) -> 
                     [HaskAST] -> [HaskAST] -> IOThrowsError [HaskAST]
  _compileBlockDo fnc result c =
    case c of
      -- Discard a value by itself
      [AstValue _] -> fnc result
      [AstRef _] -> fnc result
      _ -> fnc $ result ++ c
  
  -- TODO: could everything just be regular function calls except when a continuation is 'added to the stack' via a makeCPS(makeCPSWArgs ...) ?? I think this could be made more efficient
  
  -- |Helper function to compile expressions consisting of a scalar
  compileScalar :: String -> CompOpts -> IOThrowsError [HaskAST]
  compileScalar val copts = do 
    f <- return $ AstAssignM "x1" $ AstValue val 
    c <- return $ createAstCont copts "x1" ""
    return [createAstFunc copts [f, c]]
  
  compileScalar' :: HaskAST -> CompOpts -> IOThrowsError [HaskAST]
  compileScalar' val copts = do 
    let fCode = case val of
            AstValue v -> AstValue $ "  let x1 = " ++ v 
            AstRef r -> AstValue $ "  x1 <- " ++ r
            _ -> AstValue $ "Unexpected compiler error in compileScalar' "
    -- TODO: _
    f <- return $ fCode
    c <- return $ createAstCont copts "x1" ""
    return [createAstFunc copts [f, c]]
  
  -- |Compile the list of arguments for a function
  compileLambdaList :: [LispVal] -> IOThrowsError String
  compileLambdaList l = do
    serialized <- mapM serialize l 
    return $ "[" ++ Data.List.intercalate "," serialized ++ "]"
   where serialize (Atom a) = return $ (show a)
         serialize a = throwError $ Default $ 
                           "invalid parameter to lambda list: " ++ show a
  
  -- |Add lambda variables to the compiler's environment
  defineLambdaVars :: Env -> [LispVal] -> IOThrowsError LispVal
  defineLambdaVars env (Atom v : vs) = do
      _ <- defineVar env v $ Number 0 -- For now, actual value does not matter
      defineLambdaVars env vs
  defineLambdaVars env (_ : vs) = defineLambdaVars env vs
  defineLambdaVars _ [] = return $ Nil ""
  
  -- |Find all variables defined at "this" level and load their symbols into
  --  the environment. This allows the compiler validation to work even 
  --  though a variable is used in a sub-form before it is defined further
  --  on down in the program
  defineTopLevelVars :: Env -> [LispVal] -> IOThrowsError LispVal
  defineTopLevelVars env (List [Atom "define", Atom var, _] : ls) = do
      _ <- defineTopLevelVar env var
      defineTopLevelVars env ls
  defineTopLevelVars env ((List (Atom "define" : List (Atom var : _) : _)) : ls) = do
      _ <- defineTopLevelVar env var
      defineTopLevelVars env ls
  defineTopLevelVars env ((List (Atom "define" : DottedList (Atom var : _) _ : _)) : ls) = do
      _ <- defineTopLevelVar env var
      defineTopLevelVars env ls
  defineTopLevelVars env (_ : ls) = defineTopLevelVars env ls
  defineTopLevelVars _ _ = return nullLisp 
  
  defineTopLevelVar :: Env -> String -> IOThrowsError LispVal
  defineTopLevelVar env var = do
    defineVar env var $ Number 0 -- Actual value not loaded at the moment 
  
  -- |Compile a Lisp expression to Haskell. Note this function does
  --  not expand macros; mcompile should be used instead if macros
  --  may appear in the expression.
  compile :: Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]
  -- Experimenting with r7rs library support
  compile env 
          (List (Atom "import" : mods)) 
          copts@(CompileOptions {}) = do
      LispEnv meta <- getVar env "*meta-env*"
      LSCL.importAll env 
                     meta 
                     mods 
                    (CompileLibraryOptions compileBlock compileLisp) 
                     copts
  compile _ (Nil n) _              = return [AstValue $ "Nil " ++ (show n)]
  compile _ v@(String _) _         = return [AstValue $ ast2Str v]
  compile _ v@(Char _) _           = return [AstValue $ ast2Str v]
  compile _ v@(Complex _) _        = return [AstValue $ ast2Str v]
  compile _ v@(Float _) _          = return [AstValue $ ast2Str v]
  compile _ v@(Rational _) _       = return [AstValue $ ast2Str v]
  compile _ v@(Number _) _         = return [AstValue $ ast2Str v]
  compile _ v@(Bool _) _           = return [AstValue $ ast2Str v]
  compile _ v@(Vector _) _         = return [AstValue $ ast2Str v]
  compile _ v@(ByteVector _) _     = return [AstValue $ ast2Str v]
  compile _ ht@(HashTable _) _     = return [AstValue $ ast2Str ht]
  compile env (Atom a) _ = do
   isDefined <- liftIO $ isRecBound env a
   case isDefined of
     True -> do
  -- TODO: this is not good enough, will probably have to 
  --       return as a new type (AstGetVariable?)
       return [AstRef $ "getRTVar env \"" ++ a ++ "\""] 
     False -> throwError $ UnboundVar "Variable is not defined" a
  
  compile _ (List [Atom "quote", val]) copts = 
    compileScalar (" return $ " ++ ast2Str val) copts
  
  compile env ast@(List [Atom "expand",  _body]) copts = do
    compileSpecialFormBody env ast copts (\ _ -> do
      val <- Language.Scheme.Macro.expand env False _body LSC.apply
      compileScalar (" return $ " ++ ast2Str val) copts)
  
  compile env ast@(List (Atom "let-syntax" : List _bindings : _body)) 
          copts@(CompileOptions thisFnc a b nextFnc) = do
    compileSpecialFormBody env ast copts (\ _ -> do
      bodyEnv <- liftIO $ extendEnv env []
      _ <- Language.Scheme.Macro.loadMacros env bodyEnv Nothing False _bindings
      -- Expand whole body as a single continuous macro, to ensure hygiene
      expanded <- Language.Scheme.Macro.expand bodyEnv False (List _body) LSC.apply
  
      Atom loadMacroSym <- _gensym "loadMacroStub"
      stub <- compileScalar (" Language.Scheme.Macro.loadMacros env env Nothing False " ++ (asts2Str _bindings)) (CompileOptions thisFnc False False (Just loadMacroSym))
      rest <- divertVars bodyEnv expanded (CompileOptions loadMacroSym a b nextFnc) compexp
      return $ stub ++ rest)
   where 
       -- Pick up execution here after expansion
       compexp bodyEnv' expanded' copts' = do
         case expanded' of
           List e -> compile bodyEnv' (List $ Atom "begin" : e) copts'
           e -> compile bodyEnv' e copts'
  
  compile env ast@(List (Atom "letrec-syntax" : List _bindings : _body))
          copts@(CompileOptions thisFnc a b nextFnc) = do
    compileSpecialFormBody env ast copts (\ _ -> do
      bodyEnv <- liftIO $ extendEnv env []
      _ <- Language.Scheme.Macro.loadMacros bodyEnv bodyEnv Nothing False _bindings
      -- Expand whole body as a single continuous macro, to ensure hygiene
      expanded <- Language.Scheme.Macro.expand bodyEnv False (List _body) LSC.apply
  
      Atom loadMacroSym <- _gensym "loadMacroStub"
      stub <- compileScalar (" Language.Scheme.Macro.loadMacros env env Nothing False " ++ (asts2Str _bindings)) (CompileOptions thisFnc False False (Just loadMacroSym))
      rest <- divertVars bodyEnv expanded (CompileOptions loadMacroSym a b nextFnc) compexp
      return $ stub ++ rest)
    where 
       -- Pick up execution here after expansion
       compexp bodyEnv' expanded' copts' = do
         case expanded' of
           List e -> compile bodyEnv' (List $ Atom "begin" : e) copts'
           e -> compile bodyEnv' e copts'
  
  -- A non-standard way to rebind a macro to another keyword
  compile env 
          (List [Atom "define-syntax", 
                     Atom newKeyword,
                     Atom keyword]) 
          copts = do
    bound <- getNamespacedVar' env macroNamespace keyword
    case bound of
      Just m -> do
          _ <- defineNamespacedVar env macroNamespace newKeyword m
          compFunc <- return $ [
            AstValue $ "  bound <- getNamespacedVar' env macroNamespace \"" ++ 
                            keyword ++ "\"",
            AstValue $ "  case bound of ",
            AstValue $ "    Just m -> ",
            AstValue $ "      defineNamespacedVar env macroNamespace \"" ++ 
                                newKeyword ++ "\" m",
            AstValue $ "    Nothing -> throwError $ TypeMismatch \"macro\" $ " ++ 
                               "Atom \"" ++ keyword ++ "\"",
            createAstCont copts "(Nil \"\")" ""]
          return $ [createAstFunc copts compFunc]
      Nothing -> throwError $ TypeMismatch "macro" $ Atom keyword
  
  compile env ast@(List [Atom "define-syntax", Atom keyword,
    (List [Atom "er-macro-transformer", 
      (List (Atom "lambda" : List fparams : fbody))])])
    copts = do
    _ <- validateFuncParams fparams (Just 3)
    compileSpecialFormBody env ast copts (\ _ -> do
      let fparamsStr = asts2Str fparams
          fbodyStr = asts2Str fbody
    
      f <- makeNormalFunc env fparams fbody 
      _ <- defineNamespacedVar env macroNamespace keyword $ SyntaxExplicitRenaming f
    
      compFunc <- return $ [
        AstValue $ "  f <- makeNormalFunc env " ++ fparamsStr ++ " " ++ fbodyStr, 
        AstValue $ "  defineNamespacedVar env macroNamespace \"" ++ keyword ++ 
                        "\" $ SyntaxExplicitRenaming f",
        createAstCont copts "(Nil \"\")" ""]
      return $ [createAstFunc copts compFunc])
  
  compile env lisp@(List [Atom "define-syntax", Atom keyword, 
      (List (Atom "syntax-rules" : Atom ellipsis : (List identifiers : rules)))]) copts = do
    compileSpecialFormBody env lisp copts (\ _ -> do
      let idStr = asts2Str identifiers
          ruleStr = asts2Str rules
    
      -- Make macro available at compile time
      _ <- defineNamespacedVar env macroNamespace keyword $ 
             Syntax (Just env) Nothing False ellipsis identifiers rules
    
      -- And load it at runtime as well
      -- Env should be identical to the one loaded at compile time...
      compileScalar 
        ("  defineNamespacedVar env macroNamespace \"" ++ keyword ++ 
         "\" $ Syntax (Just env) Nothing False \"" ++ ellipsis ++ "\" " ++ idStr ++ " " ++ ruleStr) copts)
  
  compile env lisp@(List [Atom "define-syntax", Atom keyword, 
      (List (Atom "syntax-rules" : (List identifiers : rules)))]) copts = do
    compileSpecialFormBody env lisp copts (\ _ -> do
      let idStr = asts2Str identifiers
          ruleStr = asts2Str rules
    
      -- Make macro available at compile time
      _ <- defineNamespacedVar env macroNamespace keyword $ 
             Syntax (Just env) Nothing False "..." identifiers rules
    
      -- And load it at runtime as well
      -- Env should be identical to the one loaded at compile time...
      compileScalar 
        ("  defineNamespacedVar env macroNamespace \"" ++ keyword ++ 
         "\" $ Syntax (Just env) Nothing False \"...\" " ++ idStr ++ " " ++ ruleStr) copts)
  
  compile env ast@(List [Atom "if", predic, conseq]) copts = 
    compileSpecialFormBody env ast copts (\ _ -> do
      compile env (List [Atom "if", predic, conseq, Nil ""]) copts)
  
  compile env ast@(List [Atom "if", predic, conseq, alt]) copts = do
    compileSpecialFormBody env ast copts (\ nextFunc -> do
      Atom symPredicate <- _gensym "ifPredic"
      Atom symCheckPredicate <- _gensym "compiledIfPredicate"
      Atom symConsequence <- _gensym "compiledConsequence"
      Atom symAlternate <- _gensym "compiledAlternative"
  
      -- Entry point; ensure if is not rebound
      f <- return [AstValue $ "  " ++ symPredicate ++
                              " env (makeCPSWArgs env cont " ++ symCheckPredicate ++ " []) " ++ 
                              " (Nil \"\") (Just []) "]
      -- Compile expression for if's args
      compPredicate <- wrapObject symPredicate Nothing =<<
        compileExpr 
          env predic symPredicate 
          Nothing -- Do not want to call into nextFunc in the middle of (if)
      compConsequence <- wrapObject symConsequence nextFunc =<<
        compileExpr 
          env conseq symConsequence 
          nextFunc -- pick up at nextFunc after consequence
      compAlternate <- wrapObject symAlternate nextFunc =<<
        compileExpr 
          env alt symAlternate 
          nextFunc -- or... pick up at nextFunc after alternate
      -- Special case because we need to check the predicate's value
  -- FUTURE: could call a runtime function to do this, and save some code ??
      compCheckPredicate <- return $ AstFunction symCheckPredicate " env cont result _ " [
         AstValue $ "  case result of ",
         AstValue $ "    Bool False -> " ++ symAlternate ++ " env cont (Nil \"\") (Just []) ",
         AstValue $ "    _ -> " ++ symConsequence ++ " env cont (Nil \"\") (Just []) "]
      
      -- Join compiled code together
      return $ [createAstFunc copts f] ++ compPredicate ++ [compCheckPredicate] ++ 
                compConsequence ++ compAlternate)
  
  compile env ast@(List [Atom "set!", Atom var, form]) copts@(CompileOptions {}) = do
    compileSpecialFormBody env ast copts (\ _ -> do
      Atom symDefine <- _gensym "setFunc"
      Atom symMakeDefine <- _gensym "setFuncMakeSet"
  
      -- Store var in huskc's env for macro processing
      _ <- setVar env var form
  
      compDefine <- compileExpr env form symDefine $ Just symMakeDefine
      case compDefine of
        [(AstValue val)] -> do
          return [createAstFunc copts [
              AstValue $ "  result <- setVar env \"" ++ var ++ "\" $ " ++ val,
              createAstCont copts "result" ""]]
        [(AstRef val)] -> do
          return [createAstFunc copts [
              AstValue $ "  result <- setVar env \"" ++ var ++ "\" =<< " ++ val,
              createAstCont copts "result" ""]]
        _ -> do
          entryPt <- compileSpecialFormEntryPoint "set!" symDefine copts
          compMakeDefine <- return $ AstFunction symMakeDefine " env cont result _ " [
             AstValue $ "  _ <- setVar env \"" ++ var ++ "\" result",
             createAstCont copts "result" ""]
          return $ [entryPt] ++ compDefine ++ [compMakeDefine])
  
  compile env ast@(List [Atom "set!", nonvar, _]) copts = do 
    compileSpecialFormBody env ast copts (\ _ -> do
      f <- compileSpecialForm "set!" ("throwError $ TypeMismatch \"variable\"" ++
                              " $ String \"" ++ (show nonvar) ++ "\"")  copts
      return [f])
  compile env ast@(List (Atom "set!" : args)) copts = do
    compileSpecialFormBody env ast copts (\ _ -> do
      f <- compileSpecialForm "set!" ("throwError $ NumArgs 2 $ [String \"" ++ 
              (show args) ++ "\"]") copts -- Cheesy to use a string, but fine for now...
      return [f])
  
  compile env ast@(List [Atom "define", Atom var, form]) copts@(CompileOptions {}) = do
    compileSpecialFormBody env ast copts (\ _ -> do
      Atom symDefine <- _gensym "defineFuncDefine"
      Atom symMakeDefine <- _gensym "defineFuncMakeDef"
     
      -- Store var in huskc's env for macro processing (and same for other vers of define)
      _ <- defineVar env var form
  
  
      -- WORKAROUND #1
      -- Special case to support require-extension
      _ <- case form of
          List [Atom "current-environment"] -> 
              defineVar env var $ LispEnv env
          _ -> return $ Nil "" 
      -- End special case
  
     
      -- Entry point; ensure var is not rebound
      compDefine <- compileExpr env form symDefine $ Just symMakeDefine
  
      case compDefine of
        [(AstValue val)] -> do
          return [createAstFunc copts [
              AstValue $ "  result <- defineVar env \"" ++ var ++ "\" $ " ++ val,
              createAstCont copts "result" ""]]
        [(AstRef val)] -> do
          return [createAstFunc copts [
              AstValue $ "  result <- defineVar env \"" ++ var ++ "\" =<< " ++ val,
              createAstCont copts "result" ""]]
        _ -> do
          f <- return $ [
                AstValue $ "  " ++ symDefine ++ " env cont (Nil \"\") (Just [])" ]
          compMakeDefine <- return $ AstFunction symMakeDefine " env cont result _ " [
             AstValue $ "  _ <- defineVar env \"" ++ var ++ "\" result",
             createAstCont copts "result" ""]
          return $ [createAstFunc copts f] ++ compDefine ++ [compMakeDefine])
  
  compile env ast@(List (Atom "define" : List (Atom var : fparams) : fbody)) 
          copts@(CompileOptions {}) = do
    _ <- validateFuncParams fparams Nothing
    compileSpecialFormBody env ast copts (\ _ -> do
      bodyEnv <- liftIO $ extendEnv env []
      -- bind lambda params in the extended env
      _ <- defineLambdaVars bodyEnv (Atom var : fparams)
     
      Atom symCallfunc <- _gensym "defineFuncEntryPt"
      compiledParams <- compileLambdaList fparams
      compiledBody <- compileBlock symCallfunc Nothing bodyEnv [] fbody
     
      -- Cache macro expansions within function body
      ebody <- mapM (\ lisp -> Language.Scheme.Macro.macroEval env lisp LSC.apply) fbody
      -- Store var in huskc's env for macro processing (and same for other vers of define)
      _ <- makeNormalFunc env fparams ebody >>= defineVar env var
     
      -- Entry point; ensure var is not rebound
      f <- return $ [
            AstValue $ "  result <- makeNormalHFunc env (" ++ compiledParams ++ 
                       ") " ++ symCallfunc,
            AstValue $ "  _ <- defineVar env \"" ++ var ++ "\" result ",
            createAstCont copts "result" ""
            ]
      return $ (createAstFunc copts f) : compiledBody)
  
  compile env 
          ast@(List (Atom "define" : DottedList (Atom var : fparams) varargs : fbody)) 
          copts@(CompileOptions {}) = do
    _ <- validateFuncParams (fparams ++ [varargs]) Nothing
    compileSpecialFormBody env ast copts (\ _ -> do
      bodyEnv <- liftIO $ extendEnv env []
      -- bind lambda params in the extended env
      _ <- defineLambdaVars bodyEnv $ (Atom var : fparams) ++ [varargs]
     
      Atom symCallfunc <- _gensym "defineFuncEntryPt"
      compiledParams <- compileLambdaList fparams
      compiledBody <- compileBlock symCallfunc Nothing bodyEnv [] fbody
     
      -- Store var in huskc's env for macro processing (and same for other vers of define)
      ebody <- mapM (\ lisp -> Language.Scheme.Macro.macroEval env lisp LSC.apply) fbody
      _ <- makeVarargs varargs env fparams ebody >>= defineVar env var
     
      -- Entry point; ensure var is not rebound
      f <- return $ [
        AstValue $ "  result <- makeHVarargs (" ++ ast2Str varargs ++ ") env (" ++ 
                         compiledParams ++ ") " ++ symCallfunc,
        AstValue $ "  _ <- defineVar env \"" ++ var ++ "\" result ",
        createAstCont copts "result" "" ]
      return $ (createAstFunc copts f) : compiledBody)
  
  compile env ast@(List (Atom "lambda" : List fparams : fbody)) 
          copts@(CompileOptions {}) = do
    _ <- validateFuncParams fparams Nothing
    compileSpecialFormBody env ast copts (\ _ -> do
      Atom symCallfunc <- _gensym "lambdaFuncEntryPt"
      compiledParams <- compileLambdaList fparams
     
      bodyEnv <- liftIO $ extendEnv env []
      -- bind lambda params in the extended env
      _ <- defineLambdaVars bodyEnv fparams
     
      compiledBody <- compileBlock symCallfunc Nothing bodyEnv [] fbody
     
      -- Entry point; ensure var is not rebound
      f <- return $ [
            AstValue $ "  result <- makeNormalHFunc env (" ++ compiledParams ++ 
                       ") " ++ symCallfunc,
            createAstCont copts "result" ""
            ]
      return $ (createAstFunc copts f) : compiledBody)
  
  compile env ast@(List (Atom "lambda" : DottedList fparams varargs : fbody)) 
          copts@(CompileOptions {}) = do
    _ <- validateFuncParams (fparams ++ [varargs]) Nothing
    compileSpecialFormBody env ast copts (\ _ -> do
      Atom symCallfunc <- _gensym "lambdaFuncEntryPt"
      compiledParams <- compileLambdaList fparams
     
      bodyEnv <- liftIO $ extendEnv env []
      -- bind lambda params in the extended env
      _ <- defineLambdaVars bodyEnv $ fparams ++ [varargs]
     
      compiledBody <- compileBlock symCallfunc Nothing bodyEnv [] fbody
     
      -- Entry point; ensure var is not rebound
      f <- return $ [
        AstValue $ "  result <- makeHVarargs (" ++ ast2Str varargs ++ ") env (" ++ 
           compiledParams ++ ") " ++ symCallfunc,
        createAstCont copts "result" "" ]
      return $ (createAstFunc copts f) : compiledBody)
  
  compile env ast@(List (Atom "lambda" : varargs@(Atom _) : fbody)) 
          copts@(CompileOptions {}) = do
    compileSpecialFormBody env ast copts (\ _ -> do
      Atom symCallfunc <- _gensym "lambdaFuncEntryPt"
     
      bodyEnv <- liftIO $ extendEnv env []
      -- bind lambda params in the extended env
      _ <- defineLambdaVars bodyEnv [varargs]
     
      compiledBody <- compileBlock symCallfunc Nothing bodyEnv [] fbody
     
      -- Entry point; ensure var is not rebound
      f <- return $ [
            AstValue $ "  result <- makeHVarargs (" ++ ast2Str varargs ++ ") env [] " ++ symCallfunc,
            createAstCont copts "result" ""
            ]
      return $ (createAstFunc copts f) : compiledBody)
  
  compile env ast@(List [Atom "string-set!", Atom var, i, character]) copts = do
    compileSpecialFormBody env ast copts (\ _ -> do
      Atom symDefine <- _gensym "stringSetFunc"
      Atom symMakeDefine <- _gensym "stringSetFuncMakeSet"
      Atom symChr <- _gensym "stringSetChar"
      Atom symCompiledI <- _gensym "stringI"
     
      entryPt <- compileSpecialFormEntryPoint "string-set!" symChr copts
      compChr <- wrapObject symChr (Just symDefine) =<<
          compileExpr env character symChr (Just symDefine)
      compDefine <- return $ AstFunction symDefine " env cont chr _ " [
          AstValue $ "  " ++ symCompiledI ++ " env (makeCPSWArgs env cont " ++ 
            symMakeDefine ++ " [chr]) (Nil \"\") (Just []) " ]
      compI <- wrapObject symCompiledI Nothing =<<
          compileExpr env i symCompiledI Nothing
      compMakeDefine <- return $ AstFunction symMakeDefine " env cont idx (Just [chr]) " [
         AstValue $ "  tmp <- getVar env \"" ++ var ++ "\"",
         AstValue $ "  derefValue <- recDerefPtrs tmp",
         AstValue $ "  result <- substr (derefValue, chr, idx)",
         AstValue $ "  _ <- updateObject env \"" ++ var ++ "\" result",
         createAstCont copts "result" ""]
      return $ [entryPt, compDefine, compMakeDefine] ++ compI ++ compChr)
  
  compile env ast@(List [Atom "string-set!", nonvar, _, _]) copts = do 
    compileSpecialFormBody env ast copts (\ _ -> do
      f <- compileSpecialForm "string-set!" ("throwError $ TypeMismatch \"variable\"" ++
                              " $ String \"" ++ (show nonvar) ++ "\"")  copts
      return [f])
  compile env ast@(List (Atom "string-set!" : args)) copts = do
    compileSpecialFormBody env ast copts (\ _ -> do
      f <- compileSpecialForm "string-set!" ("throwError $ NumArgs 3 $ [String \"" ++ 
              (show args) ++ "\"]") copts
      return [f])
  
  compile env ast@(List [Atom "set-car!", Atom var, argObj]) copts = do
    compileSpecialFormBody env ast copts (\ _ -> do
      Atom symGetVar <- _gensym "setCarGetVar"
      Atom symCompiledObj <- _gensym "setCarCompiledObj"
      Atom symObj <- _gensym "setCarObj"
      Atom symDoSet <- _gensym "setCarDoSet"
     
      -- Code to all into next continuation from copts, if one exists
      let finalContinuation = case copts of
            (CompileOptions _ _ _ (Just nextFunc)) -> "continueEval' e (makeCPSWArgs e c " ++ nextFunc ++ " [])\n"
            _ -> "continueEval' e c\n"
     
      -- Entry point that allows set-car! to be redefined
      entryPt <- compileSpecialFormEntryPoint "set-car!" symGetVar copts
     
      -- Function to read existing var
      compGetVar <- return $ AstFunction symGetVar " env cont idx _ " [
         AstValue $ "  result <- getVar env \"" ++ var ++ "\"",
         AstValue $ "  derefValue <- recDerefPtrs result",
         AstValue $ "  " ++ symObj ++ " env cont derefValue (Just []) "]
     
      -- Compiled version of argObj
      compiledObj <- wrapObject symCompiledObj Nothing =<<
          compileExpr env argObj symCompiledObj Nothing 
     
      -- Function to check looked-up var and call into appropriate handlers; 
      -- based on code from Core
      --
      -- This is so verbose because we need to have overloads of symObj to 
      -- deal with many possible inputs.
      -- FUTURE: consider making these functions part of the runtime.
      compObj <- return $ AstValue $ "" ++
        symObj ++ " :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal\n" ++
        symObj ++ " _ _ obj@(List []) _ = throwError $ TypeMismatch \"pair\" obj\n" ++
        symObj ++ " e c obj@(List (_ : _)) _ = " ++ symCompiledObj ++ " e (makeCPSWArgs e c " ++ symDoSet ++ " [obj]) (Nil \"\") Nothing\n" ++
        symObj ++ " e c obj@(DottedList _ _) _ = " ++ symCompiledObj ++ " e (makeCPSWArgs e c " ++ symDoSet ++ " [obj]) (Nil \"\") Nothing\n" ++
        symObj ++ " _ _ obj _ = throwError $ TypeMismatch \"pair\" obj\n"
     
      -- Function to do the actual (set!), based on code from Core
      --
      -- This is so verbose because we need to have overloads of symObj to deal 
      -- with many possible inputs.
      -- FUTURE: consider making these functions part of the runtime.
      compDoSet <- return $ AstValue $ "" ++
                   symDoSet ++ " :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal\n" ++
                   symDoSet ++ " e c obj (Just [List (_ : ls)]) = updateObject e \"" ++ var ++ "\" (List (obj : ls)) >>= " ++ finalContinuation ++
                   symDoSet ++ " e c obj (Just [DottedList (_ : ls) l]) = updateObject e \"" ++ var ++ "\" (DottedList (obj : ls) l) >>= " ++ finalContinuation ++
                   symDoSet ++ " _ _ _ _ = throwError $ InternalError \"Unexpected argument to " ++ symDoSet ++ "\"\n"
     
      -- Return a list of all the compiled code
      return $ [entryPt, compGetVar, compObj, compDoSet] ++ compiledObj)
  
  compile env ast@(List [Atom "set-car!", nonvar, _]) copts = do 
    compileSpecialFormBody env ast copts (\ _ -> do
      f <- compileSpecialForm "set-car!" ("throwError $ TypeMismatch \"variable\"" ++
                              " $ String \"" ++ (show nonvar) ++ "\"")  copts
      return [f])
  compile env ast@(List (Atom "set-car!" : args)) copts = do
    compileSpecialFormBody env ast copts (\ _ -> do
      f <- compileSpecialForm "set-car!" ("throwError $ NumArgs 2 $ [String \"" ++ 
              (show args) ++ "\"]") copts
      return [f])
  
  compile env ast@(List [Atom "set-cdr!", Atom var, argObj]) copts = do
    compileSpecialFormBody env ast copts (\ _ -> do
      Atom symGetVar <- _gensym "setCdrGetVar"
      Atom symCompiledObj <- _gensym "setCdrCompiledObj"
      Atom symObj <- _gensym "setCdrObj"
      Atom symDoSet <- _gensym "setCdrDoSet"
     
      -- Code to all into next continuation from copts, if one exists
      let finalContinuation = case copts of
            (CompileOptions _ _ _ (Just nextFunc)) -> "continueEval' e (makeCPSWArgs e c " ++ nextFunc ++ " [])\n"
            _ -> "continueEval' e c\n"
     
      -- Entry point that allows set-car! to be redefined
      entryPt <- compileSpecialFormEntryPoint "set-car!" symGetVar copts
     
      -- Function to read existing var
      compGetVar <- return $ AstFunction symGetVar " env cont idx _ " [
         AstValue $ "  result <- getVar env \"" ++ var ++ "\"",
         AstValue $ "  derefValue <- recDerefPtrs result",
         AstValue $ "  " ++ symObj ++ " env cont derefValue (Just []) "]
     
      -- Compiled version of argObj
      compiledObj <- wrapObject symCompiledObj Nothing =<<
          compileExpr env argObj symCompiledObj Nothing 
     
      -- Function to check looked-up var and call into appropriate handlers; based on code from Core
      --
      -- This is so verbose because we need to have overloads of symObj to deal with many possible inputs.
      -- FUTURE: consider making these functions part of the runtime.
      compObj <- return $ AstValue $ "" ++
        symObj ++ " :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal\n" ++
        symObj ++ " _ _ obj@(List []) _ = throwError $ TypeMismatch \"pair\" obj\n" ++
     -- TODO: below, we want to make sure obj is of the right type. if so, 
     -- compile obj and call into the "set" 
     --       function below to do the actual set-car
        symObj ++ " e c obj@(List (_ : _)) _ = " ++ symCompiledObj ++ " e (makeCPSWArgs e c " ++ symDoSet ++ " [obj]) (Nil \"\") Nothing\n" ++
        symObj ++ " e c obj@(DottedList _ _) _ = " ++ symCompiledObj ++ " e (makeCPSWArgs e c " ++ symDoSet ++ " [obj]) (Nil \"\") Nothing\n" ++
        symObj ++ " _ _ obj _ = throwError $ TypeMismatch \"pair\" obj\n"
     
      -- Function to do the actual (set!), based on code from Core
      --
      -- This is so verbose because we need to have overloads of symObj 
      -- to deal with many possible inputs.
      -- FUTURE: consider making these functions part of the runtime.
      compDoSet <- return $ AstValue $ "" ++
        symDoSet ++ " :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal\n" ++
        symDoSet ++ " e c obj (Just [List (l : _)]) = do\n" ++
                    "   l' <- recDerefPtrs l\n" ++
                    "   obj' <- recDerefPtrs obj\n" ++
                    "   (cons [l', obj']) >>= updateObject e \"" ++ var ++ "\" >>= " ++ finalContinuation ++
        symDoSet ++ " e c obj (Just [DottedList (l : _) _]) = do\n" ++
                    "   l' <- recDerefPtrs l\n" ++
                    "   obj' <- recDerefPtrs obj\n" ++
                    "   (cons [l', obj']) >>= updateObject e \"" ++ var ++ "\" >>= " ++ finalContinuation ++
        symDoSet ++ " _ _ _ _ = throwError $ InternalError \"Unexpected argument to " ++ symDoSet ++ "\"\n"
     
      -- Return a list of all the compiled code
      return $ [entryPt, compGetVar, compObj, compDoSet] ++ compiledObj)
  
  compile env ast@(List [Atom "set-cdr!", nonvar, _]) copts = do 
    compileSpecialFormBody env ast copts (\ _ -> do
      f <- compileSpecialForm "set-cdr!" ("throwError $ TypeMismatch \"variable\"" ++
                              " $ String \"" ++ (show nonvar) ++ "\"")  copts
      return [f])
  compile env ast@(List (Atom "set-cdr!" : args)) copts = do
    compileSpecialFormBody env ast copts (\ _ -> do
      f <- compileSpecialForm "set-cdr!" ("throwError $ NumArgs 2 $ [String \"" ++ 
              (show args) ++ "\"]") copts
      return [f])
  
  compile env ast@(List [Atom "list-set!", Atom var, i, object]) copts = do
    compileSpecialFormBody env ast copts (\ _ -> do
      Atom symCompiledIdx <- _gensym "listSetIdx"
      Atom symCompiledObj <- _gensym "listSetObj"
      Atom symUpdateVec <- _gensym "listSetUpdate"
      Atom symIdxWrapper <- _gensym "listSetIdxWrapper"
     
      -- Entry point that allows this form to be redefined
      entryPt <- compileSpecialFormEntryPoint "list-set!" symCompiledIdx copts
      -- Compile index, then use a wrapper to pass it as an arg while compiling obj
      compiledIdx <- wrapObject symCompiledIdx (Just symIdxWrapper) =<<
          compileExpr env i symCompiledIdx (Just symIdxWrapper) 
      compiledIdxWrapper <- return $ AstFunction symIdxWrapper " env cont idx _ " [
         AstValue $ "  " ++ symCompiledObj ++ " env (makeCPSWArgs env cont " ++ symUpdateVec ++ " [idx]) (Nil \"\") (Just []) " ]
      compiledObj <- wrapObject symCompiledObj Nothing =<<
          compileExpr env object symCompiledObj Nothing
      -- Do actual update
      compiledUpdate <- return $ AstFunction symUpdateVec " env cont obj (Just [idx]) " [
         AstValue $ "  vec <- getVar env \"" ++ var ++ "\"",
         AstValue $ "  result <- updateList vec idx obj >>= updateObject env \"" ++ var ++ "\"",
         createAstCont copts "result" ""]
     
      return $ [entryPt, compiledIdxWrapper, compiledUpdate] ++ compiledIdx ++ compiledObj)
  
  compile env ast@(List [Atom "list-set!", nonvar, _, _]) copts = do 
    compileSpecialFormBody env ast copts (\ _ -> do
      f <- compileSpecialForm "list-set!" ("throwError $ TypeMismatch \"variable\"" ++
                              " $ String \"" ++ (show nonvar) ++ "\"")  copts
      return [f])
  compile env ast@(List (Atom "list-set!" : args)) copts = do
    compileSpecialFormBody env ast copts (\ _ -> do
      f <- compileSpecialForm "list-set!" ("throwError $ NumArgs 3 $ [String \"" ++ 
              (show args) ++ "\"]") copts
      return [f])
  
  compile env ast@(List [Atom "vector-set!", Atom var, i, object]) copts = do
    compileSpecialFormBody env ast copts (\ _ -> do
      Atom symCompiledIdx <- _gensym "vectorSetIdx"
      Atom symCompiledObj <- _gensym "vectorSetObj"
      Atom symUpdateVec <- _gensym "vectorSetUpdate"
      Atom symIdxWrapper <- _gensym "vectorSetIdxWrapper"
     
      -- Entry point that allows this form to be redefined
      entryPt <- compileSpecialFormEntryPoint "vector-set!" symCompiledIdx copts
      -- Compile index, then use a wrapper to pass it as an arg while compiling obj
      compiledIdx <- wrapObject symCompiledIdx (Just symIdxWrapper) =<<
          compileExpr env i symCompiledIdx (Just symIdxWrapper) 
      compiledIdxWrapper <- return $ AstFunction symIdxWrapper " env cont idx _ " [
         AstValue $ "  " ++ symCompiledObj ++ " env (makeCPSWArgs env cont " ++ symUpdateVec ++ " [idx]) (Nil \"\") (Just []) " ]
      compiledObj <- wrapObject symCompiledObj Nothing =<<
          compileExpr env object symCompiledObj Nothing
      -- Do actual update
      compiledUpdate <- return $ AstFunction symUpdateVec " env cont obj (Just [idx]) " [
         AstValue $ "  vec <- getVar env \"" ++ var ++ "\"",
         AstValue $ "  result <- updateVector vec idx obj >>= updateObject env \"" ++ var ++ "\"",
         createAstCont copts "result" ""]
     
      return $ [entryPt, compiledIdxWrapper, compiledUpdate] ++ compiledIdx ++ compiledObj)
  
  compile env ast@(List [Atom "vector-set!", nonvar, _, _]) copts = do 
    compileSpecialFormBody env ast copts (\ _ -> do
      f <- compileSpecialForm "vector-set!" ("throwError $ TypeMismatch \"variable\"" ++
                              " $ String \"" ++ (show nonvar) ++ "\"")  copts
      return [f])
  compile env ast@(List (Atom "vector-set!" : args)) copts = do
    compileSpecialFormBody env ast copts (\ _ -> do
      f <- compileSpecialForm "vector-set!" ("throwError $ NumArgs 3 $ [String \"" ++ 
              (show args) ++ "\"]") copts
      return [f])
  
  
  compile env ast@(List [Atom "bytevector-u8-set!", Atom var, i, object]) copts = do
    compileSpecialFormBody env ast copts (\ _ -> do
      Atom symCompiledIdx <- _gensym "bytevectorSetIdx"
      Atom symCompiledObj <- _gensym "bytevectorSetObj"
      Atom symUpdateVec <- _gensym "bytevectorSetUpdate"
      Atom symIdxWrapper <- _gensym "bytevectorSetIdxWrapper"
     
      -- Entry point that allows this form to be redefined
      entryPt <- compileSpecialFormEntryPoint "bytevector-u8-set!" symCompiledIdx copts
      -- Compile index, then use a wrapper to pass it as an arg while compiling obj
      compiledIdx <- wrapObject symCompiledIdx (Just symIdxWrapper) =<<
          compileExpr env i symCompiledIdx (Just symIdxWrapper) 
      compiledIdxWrapper <- return $ AstFunction symIdxWrapper " env cont idx _ " [
         AstValue $ "  " ++ symCompiledObj ++ " env (makeCPSWArgs env cont " ++ symUpdateVec ++ " [idx]) (Nil \"\") (Just []) " ]
      compiledObj <- wrapObject symCompiledObj Nothing =<<
          compileExpr env object symCompiledObj Nothing
      -- Do actual update
      compiledUpdate <- return $ AstFunction symUpdateVec " env cont obj (Just [idx]) " [
         AstValue $ "  vec <- getVar env \"" ++ var ++ "\"",
         AstValue $ "  result <- updateByteVector vec idx obj >>= updateObject env \"" ++ var ++ "\"",
         createAstCont copts "result" ""]
     
      return $ [entryPt, compiledIdxWrapper, compiledUpdate] ++ compiledIdx ++ compiledObj)
  
  compile env ast@(List [Atom "bytevector-u8-set!", nonvar, _, _]) copts = do 
    compileSpecialFormBody env ast copts (\ _ -> do
      f <- compileSpecialForm "bytevector-u8-set!" ("throwError $ TypeMismatch \"variable\"" ++
                              " $ String \"" ++ (show nonvar) ++ "\"")  copts
      return [f])
  compile env ast@(List (Atom "bytevector-u8-set!" : args)) copts = do
    compileSpecialFormBody env ast copts (\ _ -> do
      f <- compileSpecialForm "bytevector-u8-set!" ("throwError $ NumArgs 3 $ [String \"" ++ 
              (show args) ++ "\"]") copts
      return [f])
  
  compile env ast@(List [Atom "hash-table-set!", Atom var, rkey, rvalue]) copts = do
    compileSpecialFormBody env ast copts (\ _ -> do
      Atom symCompiledIdx <- _gensym "hashTableSetIdx"
      Atom symCompiledObj <- _gensym "hashTableSetObj"
      Atom symUpdateVec <- _gensym "hashTableSetUpdate"
      Atom symIdxWrapper <- _gensym "hashTableSetIdxWrapper"
     
      -- Entry point that allows this form to be redefined
      entryPt <- compileSpecialFormEntryPoint "hash-table-set!" symCompiledIdx copts
      -- Compile index, then use a wrapper to pass it as an arg while compiling obj
      compiledIdx <- wrapObject symCompiledIdx (Just symIdxWrapper) =<<
         compileExpr env rkey symCompiledIdx (Just symIdxWrapper) 
      compiledIdxWrapper <- return $ AstFunction symIdxWrapper " env cont idx _ " [
         AstValue $ "  " ++ symCompiledObj ++ " env (makeCPSWArgs env cont " ++ symUpdateVec ++ " [idx]) (Nil \"\") (Just []) " ]
      compiledObj <- wrapObject symCompiledObj Nothing =<<
         compileExpr env rvalue symCompiledObj Nothing
      -- Do actual update
      compiledUpdate <- return $ AstFunction symUpdateVec " env cont obj (Just [rkey]) " [
         -- TODO: this should be more robust, than just assuming ht is a HashTable
         AstValue $ "  HashTable ht <- getVar env \"" ++ var ++ "\"",
         AstValue $ "  HashTable ht' <- recDerefPtrs $ HashTable ht",
         AstValue $ "  result <- updateObject env \"" ++ var ++ "\" (HashTable $ Data.Map.insert rkey obj ht') ",
         createAstCont copts "result" ""]
     
      return $ [entryPt, compiledIdxWrapper, compiledUpdate] ++ compiledIdx ++ compiledObj)
  
  compile env ast@(List [Atom "hash-table-set!", nonvar, _, _]) copts = do 
    compileSpecialFormBody env ast copts (\ _ -> do
      f <- compileSpecialForm "hash-table-set!" ("throwError $ TypeMismatch \"variable\"" ++
                              " $ String \"" ++ (show nonvar) ++ "\"")  copts
      return [f])
  compile env ast@(List (Atom "hash-table-set!" : args)) copts = do
    compileSpecialFormBody env ast copts (\ _ -> do
      f <- compileSpecialForm "hash-table-set!" ("throwError $ NumArgs 3 $ [String \"" ++ 
              (show args) ++ "\"]") copts
      return [f])
  
  compile env ast@(List [Atom "hash-table-delete!", Atom var, rkey]) copts = do
    compileSpecialFormBody env ast copts (\ _ -> do
      Atom symCompiledIdx <- _gensym "hashTableDeleteIdx"
      Atom symDoDelete <- _gensym "hashTableDelete"
     
      -- Entry point that allows this form to be redefined
      entryPt <- compileSpecialFormEntryPoint "hash-table-delete!" symCompiledIdx copts
      -- Compile index, then use a wrapper to pass it as an arg while compiling obj
      compiledIdx <- wrapObject symCompiledIdx (Just symDoDelete) =<<
         compileExpr env rkey symCompiledIdx (Just symDoDelete) 
      -- Do actual update
      compiledUpdate <- return $ AstFunction symDoDelete " env cont rkey _ " [
         -- TODO: this should be more robust, than just assuming ht is a HashTable
         AstValue $ "  HashTable ht <- getVar env \"" ++ var ++ "\"",
         AstValue $ "  HashTable ht' <- recDerefPtrs $ HashTable ht",
         AstValue $ "  result <- updateObject env \"" ++ var ++ "\" (HashTable $ Data.Map.delete rkey ht') ",
         createAstCont copts "result" ""]
     
      return $ [entryPt, compiledUpdate] ++ compiledIdx)
  
  compile env ast@(List [Atom "hash-table-delete!", nonvar, _]) copts = do 
    compileSpecialFormBody env ast copts (\ _ -> do
      f <- compileSpecialForm "hash-table-delete!" ("throwError $ TypeMismatch \"variable\"" ++
                              " $ String \"" ++ (show nonvar) ++ "\"")  copts
      return [f])
  compile env ast@(List (Atom "hash-table-delete!" : args)) copts = do
    compileSpecialFormBody env ast copts (\ _ -> do
      f <- compileSpecialForm "hash-table-delete!" ("throwError $ NumArgs 2 $ [String \"" ++ 
              (show args) ++ "\"]") copts
      return [f])
  
  compile env ast@(List (Atom "%import" : args)) copts = do
    compileSpecialFormBody env ast copts (\ _ -> do
      throwError $ NotImplemented $ "%import, with args: " ++ show args)
  
  compile env (List [a@(Atom "husk-interpreter?")]) copts = do
      mfunc env (List [a, Bool True]) compile copts 
  
  compile env args@(List [Atom "load", filename, envSpec]) copts = do
    -- Explicitly do NOT call compileSpecialFormBody here, since load is not normally a special form
  
    -- F*ck it, just run the evaluator here since filename is req'd at compile time
    fname <- LSC.evalLisp env filename
    case fname of
      -- Compile contents of the file
      String fn -> compileFile fn
  
      -- Unable to get filename at compile time, fall back to loading at runtime
      _ -> mfunc env args compileApply copts
  
   where 
   compileFile filename' = do
    Atom symEnv <- _gensym "loadEnv"
    Atom symLoad <- _gensym "load"
    compEnv <- wrapObject symEnv Nothing =<<
      compileExpr env envSpec symEnv
                              Nothing -- Return env to our custom func
  
    -- WORKAROUND #1
    -- Special case to support require-extension
    env' <- case envSpec of
                 Atom a -> do
                     v <- getVar env a
                     case v of
                         LispEnv e -> return e
                         _ -> return env
                 _ -> return env
    -- End special case
  
    compLoad <- compileLisp env' filename' symLoad Nothing
   
    -- Entry point
    f <- return $ [
      -- TODO: should do runtime error checking if something else
      --       besides a LispEnv is returned
      AstValue $ "  LispEnv e <- " ++ symEnv ++ " env (makeNullContinuation env) (Nil \"\") (Just []) ",
      AstValue $ "  result <- " ++ symLoad ++ " e (makeNullContinuation e) (Nil \"\") Nothing",
      createAstCont copts "result" ""]
    -- Join compiled code together
    return $ [createAstFunc copts f] ++ compEnv ++ compLoad
  
  compile env (List [Atom "load", filename]) copts = do -- TODO: allow filename from a var, support env optional arg
   -- TODO: error handling for string below
   String filename' <- LSC.evalLisp env filename
   Atom symEntryPt <- _gensym "load"
   result <- compileLisp env filename' symEntryPt Nothing
   return $ result ++ 
     [createAstFunc copts [
      AstValue $ "  result <- " ++ symEntryPt ++ 
                 " env (makeNullContinuation env) (Nil \"\") Nothing",
      createAstCont copts "result" ""]]
  
  -- FUTURE: eventually it should be possible to evaluate the args instead of assuming
  -- that they are all strings, but lets keep it simple for now
  compile env (List [Atom "load-ffi", 
                          String moduleName, 
                          String externalFuncName, 
                          String internalFuncName]) copts = do
  --  Atom symLoadFFI <- _gensym "loadFFI"
  
    -- Only append module again if it is not already in the list
    List l <- getNamespacedVar env 't' {-"internal"-} "imports"
    _ <- if String moduleName `notElem` l
            then setNamespacedVar env 't' {-"internal"-} "imports" $ 
                                  List $ l ++ [String moduleName]
            else return $ String ""
  
    -- Pass along moduleName as another top-level import
    return [createAstFunc copts [
      AstValue $ "  result <- defineVar env \"" ++ 
          internalFuncName ++ "\" $ IOFunc " ++ 
          moduleName ++ "." ++ externalFuncName,
      createAstCont copts "result" ""]]
  
  compile env args@(List (_ : _)) copts = mfunc env args compileApply copts 
  compile _ badForm _ = throwError $ BadSpecialForm "Unrecognized special form" badForm
  
  -- |Expand macros and compile the resulting code
  mcompile :: Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]
  mcompile env lisp = mfunc env lisp compile
  
  -- |Expand macros and then pass control to the given function 
  mfunc :: Env
        -> LispVal 
        -> (Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]) 
        -> CompOpts 
        -> IOThrowsError [HaskAST] 
  mfunc env lisp func copts = do
    expanded <- Language.Scheme.Macro.macroEval env lisp LSC.apply
    divertVars env expanded copts func
  
  -- |Do the actual insertion of diverted variables back to the 
  --  compiled program.
  divertVars 
      :: Env 
      -- ^ Current compile Environment
      -> LispVal
      -- ^ Lisp code after macro expansion
      -> CompOpts
      -- ^ Compiler options
      -> (Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST])
      -- ^ Continuation to call into after vars are diverted
      -> IOThrowsError [HaskAST]
      -- ^ Code generated by the continuation, along with the code
      --   added to divert vars to the compiled program
  divertVars env expanded copts@(CompileOptions _ uvar uargs nfnc) func = do
    vars <- Language.Scheme.Macro.getDivertedVars env
    case vars of 
      [] -> func env expanded copts
      _ -> do 
        Atom symNext <- _gensym "afterDivert"
        diverted <- compileDivertedVars symNext env vars copts
        rest <- wrapObject symNext nfnc =<<
          func env expanded (CompileOptions symNext uvar uargs nfnc)
        return $ diverted : rest
  
  -- |Take a list of variables diverted into env at compile time, and
  --  divert them into the env at runtime
  compileDivertedVars :: String -> Env -> [LispVal] -> CompOpts -> IOThrowsError HaskAST
  compileDivertedVars 
    formNext _ vars 
    copts@(CompileOptions _ useVal useArgs _) = do
    let val = case useVal of
          True -> "value"
          _ -> "Nil \"\""
        args = case useArgs of
          True -> "(Just args)"
          _ -> "(Just [])"
        comp (List [Atom renamed, Atom orig]) = do
          [AstValue $ "  v <- getVar env \"" ++ orig ++ "\"",
           AstValue $ "  _ <- defineVar env \"" ++ renamed ++ "\" v"]
        comp _ = []
        cvars = map comp vars 
        f = (concat cvars) ++ 
            [AstValue $ "  " ++ formNext ++ " env cont (" ++ val ++ ") " ++ args]
    return $ createAstFunc copts f
  
  -- |Create the function entry point for a special form
  compileSpecialFormEntryPoint :: String -> String -> CompOpts -> IOThrowsError HaskAST
  compileSpecialFormEntryPoint formName formSym copts = do
   compileSpecialForm formName ("" ++ formSym ++ " env cont (Nil \"\") (Just [])") copts
  
  -- | Helper function for compiling a special form
  compileSpecialForm :: String -> String -> CompOpts -> IOThrowsError HaskAST
  compileSpecialForm _ formCode copts = do
   f <- return $ [
         AstValue $ "  " ++ formCode]
   return $ createAstFunc copts f
  
  -- |A wrapper for each special form that allows the form variable 
  --  (EG: "if") to be redefined at compile time
  compileSpecialFormBody :: Env
                         -> LispVal
                         -> CompOpts
                         -> (Maybe String -> ExceptT LispError IO [HaskAST])
                         -> ExceptT LispError IO [HaskAST]
  compileSpecialFormBody env 
                         ast@(List (Atom fnc : _)) 
                         copts@(CompileOptions _ _ _ nextFunc) 
                         spForm = do
    isDefined <- liftIO $ isRecBound env fnc
    case isDefined of
      True -> mfunc env ast compileApply copts 
      False -> spForm nextFunc
  compileSpecialFormBody _ _ _ _ = throwError $ InternalError "compileSpecialFormBody"
  
  -- | Compile an intermediate expression (such as an arg to if) and 
  --   call into the next continuation with it's value
  compileExpr :: Env -> LispVal -> String -> Maybe String -> IOThrowsError [HaskAST]
  compileExpr env expr symThisFunc fForNextExpr = do
    mcompile env expr (CompileOptions symThisFunc False False fForNextExpr) 
  
  -- |Compile a function call
  compileApply :: Env -> LispVal -> CompOpts -> IOThrowsError [HaskAST]
  compileApply env (List (func : fparams)) copts@(CompileOptions coptsThis _ _ coptsNext) = do
  
  --
  -- TODO: it is probably possible to mix creating conts and not when there are func and non-func args.
  --  
  --  _ <- case (trace ("calling compileApply: " ++ show (List (func : fparams))) func) of
    _ <- case func of
      List _ -> return $ Nil ""
      Atom _ -> return $ Nil "" 
      _ -> throwError $ BadSpecialForm "Unable to evaluate form" $ List (func : fparams)
  
    primitive <- isPrim env func
    let literals = collectLiterals fparams 
        nonFunctionCalls = collectLiteralsAndVars fparams
  
    case (primitive, literals, nonFunctionCalls) of
       -- Primitive (non-I/O) function with literal args, 
       -- evaluate at compile time
       (Just primFunc, Just ls, _) -> do
         result <- LSC.apply 
          (makeNullContinuation env)
          primFunc
          ls
  
         return $ [createAstFunc copts [
           AstValue $ "  let result = " ++ (ast2Str result),
           createAstCont copts "result" ""]]
  
       -- Other function with literal args, no need to create a
       -- continuation chain. But this case may include I/O funcs and
       -- variables, so everything must be executed at runtime
       (_, _, Just ls) -> compileFuncLitArgs ls
       
       -- Any other function, do it the hard way...
       --
       -- Compile the function and each argument as a link in
       -- a chain of continuations.
       _ -> compileAllArgs func
  
   where 
    -- |Compile a function call that contains arguments that are not
    --  function calls executed at runtime.
    compileFuncLitArgs args = do
         -- Keep track of any variables since we need to do a
         -- 'getRtVar' lookup for each of them prior to apply
         let pack (Atom p : ps) strs vars i = do
               let varName = 'v' : show i
               pack ps 
                    (strs ++ [varName]) 
                    (vars ++ [(p, varName)]) 
                    (i + 1)
             pack (p : ps) strs vars i = 
               pack ps 
                    (strs ++ [ast2Str p]) 
                    vars 
                    i
             pack [] strs vars _ = (strs, vars)
         let (paramStrs, vars) = pack args [] [] (0::Int)
         _compileFuncLitArgs func vars $ "[" ++ joinL paramStrs "," ++ "]"
  
    _compileFuncLitArgs fnc vars args = do
      Atom stubFunc <- _gensym "applyStubF"
      Atom nextFunc <- _gensym "applyNextF"
  
      -- Haskell variables must be used to retrieve each atom from the env
      let varLines = 
            map (\ (rt, cp) -> 
                    AstValue $ "  " ++ cp ++ " <- getRTVar env \"" ++ rt ++ "\"")
                vars
  
      rest <- case coptsNext of
               Nothing -> return $ [
                 AstFunction nextFunc
                  " env cont value _ " $ varLines ++ 
                  [AstValue $ "  apply cont value " ++ args]]
               Just fnextExpr -> return $ [
                 AstFunction nextFunc 
                  " env cont value _ " $ varLines ++ 
                  [AstValue $ "  apply (makeCPSWArgs env cont " ++ 
                              fnextExpr ++ " []) value " ++ args]]
  
      _comp <- mcompile env fnc $ CompileOptions stubFunc False False Nothing
      case _comp of
          [(AstValue val)] -> do
            return $ [createAstFunc 
                      (CompileOptions coptsThis False False Nothing) [
                       AstValue $ "  let var = " ++ val,
                       AstValue $ "  " ++ nextFunc ++ " env cont var Nothing"]] ++ rest
          [(AstRef val)] -> do
            return $ [createAstFunc 
                      (CompileOptions coptsThis False False Nothing) [
                       AstValue $ "  var <- " ++ val,
                       AstValue $ "  " ++ nextFunc ++ " env cont var Nothing"]] ++ rest
          _ -> do
            c <- return $ 
              AstFunction coptsThis " env cont _ _ " [
                AstValue $ "  " ++ stubFunc ++ " env (makeCPSWArgs env cont " ++ 
                           nextFunc ++ " []) (Nil \"\") (Just [])"]  
        
            return $ [c] ++ _comp ++ rest
  
    -- |Compile function and args as a chain of continuations
  -- TODO:
    compileAllArgs (Atom fncName) = do
      rest <- case fparams of
      --rest <- case (trace "fncName" fparams) of
                [] -> do
                    throwError $ Default $ " unreachable code in compileAllArgs for " ++ fncName
  --                fnc <- compileInlineVar env fncName "fnc"
  --                return [AstFunction 
  --                          coptsThis
  --                          " env cont (Nil _) (Just (a:as)) "
  --                          [fnc,
  --                           AstValue $ "  apply " ++ applyCont ++ " fnc (a:as) "],
  --                        AstFunction 
  --                          coptsThis
  --                          " env cont value (Just (a:as)) " 
  --                          [fnc,
  --                           AstValue $ "  apply " ++ applyCont ++ " fnc $ (a:as) ++ [value] "]]
                _ -> compileArgs coptsThis True (Just fncName) fparams -- True, passing fnc as value
      return $ rest
      --return $ [c, wrapper ] ++ _comp ++ rest
    compileAllArgs func' = do
      Atom stubFunc <- _gensym "applyStubF"
      Atom wrapperFunc <- _gensym "applyWrapper"
      Atom nextFunc <- _gensym "applyNextF"
  
      -- Use wrapper to pass high-order function (func) as an argument to apply
      wrapper <- return $ 
        AstFunction wrapperFunc " env cont value _ " [
            AstValue $ "  " ++ nextFunc ++ " env cont " ++ 
                       " (Nil \"\") (Just [value]) "]
      --rest <- case (trace ("func' = " ++ (show func') ++ ", fparams = " ++ (show fparams)) fparams) of
      rest <- case fparams of
                [] -> do
                  return [AstFunction 
                            nextFunc 
                            " env cont (Nil _) (Just (a:as)) "
                            [AstValue $ "  apply " ++ applyCont ++ " a as "],
                          AstFunction 
                            nextFunc 
                            " env cont value (Just (a:as)) " 
                            [AstValue $ "  apply " ++ applyCont ++ " a $ as ++ [value] "]]
                _ -> compileArgs nextFunc False Nothing fparams -- False since no value passed in this time
  
      _comp <- mcompile env func' $ CompileOptions stubFunc False False Nothing
      case _comp of
          [(AstValue val)] -> do
            return $ [createAstFunc 
                      (CompileOptions coptsThis False False Nothing) [
                       AstValue $ "  let var = " ++ val,
                       AstValue $ "  " ++ wrapperFunc ++ " env cont var Nothing"]] ++ rest
          [(AstRef val)] -> do
            return $ [createAstFunc 
                      (CompileOptions coptsThis False False Nothing) [
                       AstValue $ "  var <- " ++ val,
                       AstValue $ "  " ++ wrapperFunc ++ " env cont var Nothing"]] ++ rest
          _ -> do
            c <- return $ 
              AstFunction coptsThis " env cont _ _ " [
                AstValue $ "  " ++ stubFunc ++ " env (makeCPSWArgs env cont " ++ 
                           wrapperFunc ++ " []) (Nil \"\") (Just [])"]  
            return $ [c, wrapper ] ++ _comp ++ rest
  
    applyCont :: String
    applyCont = case coptsNext of
                  Nothing -> "cont"
                  Just fnextExpr -> "(makeCPSWArgs env cont " ++ fnextExpr ++ " [])"
  
    -- |Compile each argument as its own continuation (lambda), and then
    --  call the function using @applyWrapper@
    compileArgs :: String -> Bool -> (Maybe String) -> [LispVal] -> IOThrowsError [HaskAST]
    compileArgs thisFunc thisFuncUseValue maybeFnc args = do
      case args of
        (a:as) -> do
          let (asRest, asLiterals) = (as, [])
  --        let (asRest, asLiterals) = takeLiterals a as
          let lastArg = null asRest
          Atom stubFunc <- _gensym "applyFirstArg" -- Call into compiled stub
          Atom nextFunc <- do
              case lastArg of
                  True -> return $ Atom "applyWrapper" -- Use wrapper to call into /apply/
                  _ -> _gensym "applyNextArg" -- Next func argument to execute...
  
          -- inline function?
          fnc <- case maybeFnc of
                   Just fncName -> do
                      var <- compileInlineVar env fncName "value"
                      return [var]
                   _ -> return []
  
          -- Flag below means that the expression's value matters, add it to args
          let fargs = if thisFuncUseValue
                         then " env cont value (Just args) "
                         else " env cont _ (Just args) "
          rest <- case lastArg of
                       True -> return [] -- Using apply wrapper, so no more code
                       _ -> compileArgs nextFunc True Nothing asRest -- True indicates nextFunc needs to use value arg passed into it
          let nextCont' = case (lastArg, coptsNext) of
                              (True, Just fnextExpr) -> "(makeCPSWArgs env cont " ++ fnextExpr ++ " [])"
                              _ -> "cont"
          let literalArgs = asts2Str asLiterals
          let argsCode = case thisFuncUseValue of
                           True -> " $ args ++ [value] ++ " ++ literalArgs ++ ") " 
                           False -> " $ args ++ " ++ literalArgs ++ ") "
  
          _comp <- mcompile env a $ CompileOptions stubFunc thisFuncUseValue False Nothing
          case _comp of
              [(AstValue val)] -> do
                c <- do
                     return [AstValue $ "  let var = " ++ val,
                             AstValue $ "  " ++ nextFunc ++ " env " ++ nextCont' ++ " var (Just " ++ argsCode]
                return $ [AstFunction thisFunc fargs (fnc ++ c)] ++ rest
              [(AstRef val)] -> do
                c <- do
                     return [AstValue $ "  var <- " ++ val,
                             AstValue $ "  " ++ nextFunc ++ " env " ++ nextCont' ++ " var (Just " ++ argsCode]
                return $ [AstFunction thisFunc fargs (fnc ++ c)] ++ rest
              _ -> do
                let c = AstValue $
                          "  continueEval' env (makeCPSWArgs env (makeCPSWArgs env " ++
                          nextCont' ++ " " ++ nextFunc ++ argsCode ++ stubFunc ++
                          " []) $ Nil\"\""
  -- TODO: not good enough, generated functions assume args come from continuation and not parameter
  --              let c = AstValue $ "  " ++ stubFunc ++ " env (makeCPS env " ++ nextCont' ++ " " ++ nextFunc ++ " ) " ++
  --                                 " (Nil \"\") (Just " ++ argsCode
                return $ [AstFunction thisFunc fargs (fnc ++ [c])] ++ _comp ++ rest
  
        _ -> throwError $ TypeMismatch "nonempty list" $ List args
  
  compileApply _ err _ = do
      throwError $ Default $ "compileApply - Unexpected argument: " ++ show err
  
  -- |Determines if the given lispval is a primitive function
  isPrim :: Env -> LispVal -> IOThrowsError (Maybe LispVal)
  isPrim env (Atom func) = do
    val <- getVar env func >>= recDerefPtrs
    case val of
        p@(PrimitiveFunc _) -> return $ Just p
        _ -> return Nothing
  isPrim _ p@(PrimitiveFunc _) = return $ Just p
  isPrim _ _ = return Nothing
  
  -- |Determine if the given list of expressions contains only literal identifiers
  --  EG: 1, "2", etc. And return them if that is all that is found.
  --
  -- Atoms are a special case since they denote variables that will only be
  -- available at runtime, so a flag is used to selectively include them.
  --
  _collectLiterals :: [LispVal] -> [LispVal] -> Bool -> (Maybe [LispVal])
  _collectLiterals (List _ : _) _ _ = Nothing
  _collectLiterals (Atom _ : _) _ False = Nothing
  _collectLiterals (a : as) nfs varFlag = _collectLiterals as (a : nfs) varFlag
  _collectLiterals [] nfs _ = Just $ reverse nfs
  
  -- Wrappers for the above function
  collectLiterals, collectLiteralsAndVars :: [LispVal] -> (Maybe [LispVal])
  collectLiteralsAndVars args = _collectLiterals args [] True
  collectLiterals args = _collectLiterals args [] False
  
  -- Experimental:
  -- -- Take as many literals as possible from the given list, and
  -- -- return those literals and the rest of the list
  -- takeLiterals :: LispVal -> [LispVal] -> ([LispVal], [LispVal])
  -- takeLiterals (List _) ls = (ls, [])
  -- takeLiterals _ ls' = do
  --   loop ls' []
  --  where
  --   loop (l : ls) acc = do
  --     if isLiteral l
  --        then loop ls (l : acc)
  --        else ((l:ls), Data.List.reverse acc)
  --   loop [] acc = ([], Data.List.reverse acc)
  -- 
  --   isLiteral (List _) = False
  --   isLiteral (Atom _) = False
  --   isLiteral _ = True
  
  -- Compile variable as a stand-alone line of code
  compileInlineVar :: Env -> String -> String -> IOThrowsError HaskAST
  compileInlineVar env a hsName = do
   isDefined <- liftIO $ isRecBound env a
   case isDefined of
     True -> return $ AstValue $ "  " ++ hsName ++ " <- getRTVar env \"" ++ a ++ "\""
     False -> throwError $ UnboundVar "Variable is not defined" a
  
  -- Helper function to determine if a value/ref was received
  isSingleValue :: [HaskAST] -> Bool
  isSingleValue [(AstValue _)] = True
  isSingleValue [(AstRef _)] = True
  isSingleValue _ = False
  
  wrapObject :: String
                -> Maybe String -> [HaskAST] -> IOThrowsError [HaskAST]
  wrapObject thisF nextF es = do
   case es of
    [val@(AstValue _)] -> compileScalar' val $ CompileOptions thisF False False nextF
    [val@(AstRef _)] -> compileScalar' val $ CompileOptions thisF False False nextF
    _ -> return es
  
  