~technomancy/antifennel

1720f91e65e045b3a7062979457f219e39de10eb — Phil Hagelberg a month ago 4641f06
Upgrade to latest Fennel version.
M changelog.md => changelog.md +1 -0
@@ 2,6 2,7 @@

## 0.2.0 / ???

* Upgrade to Fennel 0.7.0.
* Use `let` where appropriate to replace `do+local` or directly inside `fn`.
* Emit identifiers using kebab-case instead of camelCase or snake_case.
* Compile `local f = function()` to `fn` idiomatically.

M fennel => fennel +3278 -3363
@@ 1,12 1,11 @@
#!/usr/bin/env lua
package.preload["fennelbinary"] = package.preload["fennelbinary"] or function(...)
package.preload["fennel.binary"] = package.preload["fennel.binary"] or function(...)
  local fennel = require("fennel")
  local function shellout(command)
    local f = io.popen(command)
    local stdout = f:read("*all")
    return (f:close() and stdout)
  end
  pcall(function() require("fennel").metadata:setall(shellout, "fnl/arglist", {"command"}) end)
  local function execute(cmd)
    local _0_0 = os.execute(cmd)
    if (_0_0 == 0) then


@@ 15,7 14,6 @@ package.preload["fennelbinary"] = package.preload["fennelbinary"] or function(..
      return true
    end
  end
  pcall(function() require("fennel").metadata:setall(execute, "fnl/arglist", {"cmd"}) end)
  local function string__3ec_hex_literal(characters)
    local hex = {}
    for character in characters:gmatch(".") do


@@ 23,7 21,6 @@ package.preload["fennelbinary"] = package.preload["fennelbinary"] or function(..
    end
    return table.concat(hex, ", ")
  end
  pcall(function() require("fennel").metadata:setall(string__3ec_hex_literal, "fnl/arglist", {"characters"}) end)
  local c_shim = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n#include <lauxlib.h>\n#include <lua.h>\n#include <lualib.h>\n#ifdef __cplusplus\n}\n#endif\n#include <signal.h>\n#include <stdio.h>\n#include <stdlib.h>\n#include <string.h>\n\n#if LUA_VERSION_NUM == 501\n  #define LUA_OK 0\n#endif\n\n/* Copied from lua.c */\n\nstatic lua_State *globalL = NULL;\n\nstatic void lstop (lua_State *L, lua_Debug *ar) {\n  (void)ar;  /* unused arg. */\n  lua_sethook(L, NULL, 0, 0);  /* reset hook */\n  luaL_error(L, \"interrupted!\");\n}\n\nstatic void laction (int i) {\n  signal(i, SIG_DFL); /* if another SIGINT happens, terminate process */\n  lua_sethook(globalL, lstop, LUA_MASKCALL | LUA_MASKRET | LUA_MASKCOUNT, 1);\n}\n\nstatic void createargtable (lua_State *L, char **argv, int argc, int script) {\n  int i, narg;\n  if (script == argc) script = 0;  /* no script name? */\n  narg = argc - (script + 1);  /* number of positive indices */\n  lua_createtable(L, narg, script + 1);\n  for (i = 0; i < argc; i++) {\n    lua_pushstring(L, argv[i]);\n    lua_rawseti(L, -2, i - script);\n  }\n  lua_setglobal(L, \"arg\");\n}\n\nstatic int msghandler (lua_State *L) {\n  const char *msg = lua_tostring(L, 1);\n  if (msg == NULL) {  /* is error object not a string? */\n    if (luaL_callmeta(L, 1, \"__tostring\") &&  /* does it have a metamethod */\n        lua_type(L, -1) == LUA_TSTRING)  /* that produces a string? */\n      return 1;  /* that is the message */\n    else\n      msg = lua_pushfstring(L, \"(error object is a %%s value)\",\n                            luaL_typename(L, 1));\n  }\n  /* Call debug.traceback() instead of luaL_traceback() for Lua 5.1 compat. */\n  lua_getglobal(L, \"debug\");\n  lua_getfield(L, -1, \"traceback\");\n  /* debug */\n  lua_remove(L, -2);\n  lua_pushstring(L, msg);\n  /* original msg */\n  lua_remove(L, -3);\n  lua_pushinteger(L, 2);  /* skip this function and traceback */\n  lua_call(L, 2, 1); /* call debug.traceback */\n  return 1;  /* return the traceback */\n}\n\nstatic int docall (lua_State *L, int narg, int nres) {\n  int status;\n  int base = lua_gettop(L) - narg;  /* function index */\n  lua_pushcfunction(L, msghandler);  /* push message handler */\n  lua_insert(L, base);  /* put it under function and args */\n  globalL = L;  /* to be available to 'laction' */\n  signal(SIGINT, laction);  /* set C-signal handler */\n  status = lua_pcall(L, narg, nres, base);\n  signal(SIGINT, SIG_DFL); /* reset C-signal handler */\n  lua_remove(L, base);  /* remove message handler from the stack */\n  return status;\n}\n\nint main(int argc, char *argv[]) {\n lua_State *L = luaL_newstate();\n luaL_openlibs(L);\n createargtable(L, argv, argc, 0);\n\n static const unsigned char lua_loader_program[] = {\n%s\n};\n  if(luaL_loadbuffer(L, (const char*)lua_loader_program,\n                     sizeof(lua_loader_program), \"%s\") != LUA_OK) {\n    fprintf(stderr, \"luaL_loadbuffer: %%s\\n\", lua_tostring(L, -1));\n    lua_close(L);\n    return 1;\n  }\n\n  /* lua_bundle */\n  lua_newtable(L);\n  static const unsigned char lua_require_1[] = {\n  %s\n  };\n  lua_pushlstring(L, (const char*)lua_require_1, sizeof(lua_require_1));\n  lua_setfield(L, -2, \"%s\");\n\n%s\n\n  if (docall(L, 1, LUA_MULTRET)) {\n    const char *errmsg = lua_tostring(L, 1);\n    if (errmsg) {\n      fprintf(stderr, \"%%s\\n\", errmsg);\n    }\n    lua_close(L);\n    return 1;\n  }\n  lua_close(L);\n  return 0;\n}"
  local function compile_fennel(filename, options)
    local f = nil


@@ 32,16 29,15 @@ package.preload["fennelbinary"] = package.preload["fennelbinary"] or function(..
    else
      f = assert(io.open(filename, "rb"))
    end
    local lua_code = fennel.compileString(f:read("*a"), options)
    local lua_code = fennel["compile-string"](f:read("*a"), options)
    f:close()
    return lua_code
  end
  pcall(function() require("fennel").metadata:setall(compile_fennel, "fnl/arglist", {"filename", "options"}) end)
  local function native_loader(native)
    local nm = (os.getenv("NM") or "nm")
    local out = {"  /* native libraries */"}
    for _, path in ipairs(native) do
      for open in shellout((nm .. " " .. path)):gmatch("[^dD] _?luaopen_([%a%p%d]+)") do
      for open in shellout((nm .. " " .. path)):gmatch("[^dDt] _?luaopen_([%a%p%d]+)") do
        table.insert(out, ("  int luaopen_%s(lua_State *L);"):format(open))
        table.insert(out, ("  lua_pushcfunction(L, luaopen_%s);"):format(open))
        table.insert(out, ("  lua_setfield(L, -2, \"%s\");\n"):format((open:sub(1, 1) .. open:sub(2):gsub("_", "."))))


@@ 49,7 45,6 @@ package.preload["fennelbinary"] = package.preload["fennelbinary"] or function(..
    end
    return table.concat(out, "\n")
  end
  pcall(function() require("fennel").metadata:setall(native_loader, "fnl/arglist", {"native"}) end)
  local function fennel__3ec(filename, native, options)
    local basename = filename:gsub("(.*[\\/])(.*)", "%2")
    local basename_noextension = (basename:match("(.+)%.") or basename)


@@ 61,10 56,9 @@ package.preload["fennelbinary"] = package.preload["fennelbinary"] or function(..
      _0_ = "(do (local bundle_0_ ...) (fn loader_0_ [name_0_] (match (or (. bundle_0_ name_0_) (. bundle_0_ (.. name_0_ \".init\"))) (mod_0_ ? (= \"function\" (type mod_0_))) mod_0_ (mod_0_ ? (= \"string\" (type mod_0_))) (assert (if (= _VERSION \"Lua 5.1\") (loadstring mod_0_ name_0_) (load mod_0_ name_0_))) nil (values nil (: \"\\n\\tmodule '%%s' not found in fennel bundle\" \"format\" name_0_)))) (table.insert (or package.loaders package.searchers) 2 loader_0_) ((assert (loader_0_ \"%s\")) ((or unpack table.unpack) arg)))"
    end
    fennel_loader = _0_:format(dotpath_noextension)
    local lua_loader = fennel.compileString(fennel_loader)
    local lua_loader = fennel["compile-string"](fennel_loader)
    return c_shim:format(string__3ec_hex_literal(lua_loader), basename_noextension, string__3ec_hex_literal(compile_fennel(filename, options)), dotpath_noextension, native_loader(native))
  end
  pcall(function() require("fennel").metadata:setall(fennel__3ec, "fnl/arglist", {"filename", "native", "options"}) end)
  local function write_c(filename, native, options)
    local out_filename = (filename .. "_binary.c")
    local f = assert(io.open(out_filename, "w+"))


@@ 72,7 66,6 @@ package.preload["fennelbinary"] = package.preload["fennelbinary"] or function(..
    f:close()
    return out_filename
  end
  pcall(function() require("fennel").metadata:setall(write_c, "fnl/arglist", {"filename", "native", "options"}) end)
  local function compile_binary(lua_c_path, executable_name, static_lua, lua_include_dir, native)
    local cc = (os.getenv("CC") or "cc")
    local rdynamic, bin_extension, ldl_3f = nil, nil, nil


@@ 101,7 94,6 @@ package.preload["fennelbinary"] = package.preload["fennelbinary"] or function(..
    end
    return os.exit(0)
  end
  pcall(function() require("fennel").metadata:setall(compile_binary, "fnl/arglist", {"lua-c-path", "executable-name", "static-lua", "lua-include-dir", "native"}) end)
  local function native_path_3f(path)
    local _0_0 = path:match("%.(%a+)$")
    if (_0_0 == "a") then


@@ 112,9 104,11 @@ package.preload["fennelbinary"] = package.preload["fennelbinary"] or function(..
      return path
    elseif (_0_0 == "dylib") then
      return path
    else
      local _ = _0_0
      return false
    end
  end
  pcall(function() require("fennel").metadata:setall(native_path_3f, "fnl/arglist", {"path"}) end)
  local function extract_native_args(args)
    local native = {libraries = {}, modules = {}}
    for i = #args, 1, -1 do


@@ 135,14 129,12 @@ package.preload["fennelbinary"] = package.preload["fennelbinary"] or function(..
    end
    return native
  end
  pcall(function() require("fennel").metadata:setall(extract_native_args, "fnl/arglist", {"args"}) end)
  local function compile(filename, executable_name, static_lua, lua_include_dir, options, args)
    local _0_ = extract_native_args(args)
    local libraries = _0_["libraries"]
    local modules = _0_["modules"]
    return compile_binary(write_c(filename, modules, options), executable_name, static_lua, lua_include_dir, libraries)
  end
  pcall(function() require("fennel").metadata:setall(compile, "fnl/arglist", {"filename", "executable-name", "static-lua", "lua-include-dir", "options", "args"}) end)
  local help = ("\nUsage: %s --compile-binary FILE OUT STATIC_LUA_LIB LUA_INCLUDE_DIR\n\nCompile a binary from your Fennel program. This functionality is VERY\nexperimental and subject to change in future versions!\n\nRequires a C compiler, a copy of liblua, and Lua's dev headers. Implies\nthe --require-as-include option.\n\n  FILE: the Fennel source being compiled.\n  OUT: the name of the executable to generate\n  STATIC_LUA_LIB: the path to the Lua library to use in the executable\n  LUA_INCLUDE_DIR: the path to the directory of Lua C header files\n\nFor example, on a Debian system, to compile a file called program.fnl using\nLua 5.3, you would use this:\n\n    $ %s --compile-binary program.fnl program \\\n        /usr/lib/x86_64-linux-gnu/liblua5.3.a /usr/include/lua5.3\n\nThe program will be compiled to Lua, then compiled to C, then compiled to\nmachine code. You can set the CC environment variable to change the compiler\nused (default: cc) or set CC_OPTS to pass in compiler options. For example\nset CC_OPTS=-static to generate a binary with static linking.\n\nTo include C libraries that contain Lua modules, add --native-module path/to.so,\nand to include C libraries without modules, use --native-library path/to.so.\nThese options are unstable, barely tested, and even more likely to break.\n\nThis method is currently limited to programs do not transitively require Lua\nmodules. Requiring a Lua module directly will work, but requiring a Lua module\nwhich requires another will fail."):format(arg[0], arg[0])
  return {compile = compile, help = help}
end


@@ 150,7 142,6 @@ package.preload["fennelview"] = package.preload["fennelview"] or function(...)
  local function view_quote(str)
    return ("\"" .. str:gsub("\"", "\\\"") .. "\"")
  end
  pcall(function() require("fennel").metadata:setall(view_quote, "fnl/arglist", {"str"}) end)
  local short_control_char_escapes = {["\11"] = "\\v", ["\12"] = "\\f", ["\13"] = "\\r", ["\7"] = "\\a", ["\8"] = "\\b", ["\9"] = "\\t", ["\n"] = "\\n"}
  local long_control_char_escapes = nil
  do


@@ 167,16 158,14 @@ package.preload["fennelview"] = package.preload["fennelview"] or function(...)
  local function escape(str)
    return str:gsub("\\", "\\\\"):gsub("(%c)%f[0-9]", long_control_char_escapes):gsub("%c", short_control_char_escapes)
  end
  pcall(function() require("fennel").metadata:setall(escape, "fnl/arglist", {"str"}) end)
  local function sequence_key_3f(k, len)
    return ((type(k) == "number") and (1 <= k) and (k <= len) and (math.floor(k) == k))
  end
  pcall(function() require("fennel").metadata:setall(sequence_key_3f, "fnl/arglist", {"k", "len"}) end)
  local type_order = {["function"] = 5, boolean = 2, number = 1, string = 3, table = 4, thread = 7, userdata = 6}
  local function sort_keys(a, b)
    local ta = type(a)
    local tb = type(b)
    if ((ta == tb) and (ta ~= "boolean") and ((ta == "string") or (ta == "number"))) then
    if ((ta == tb) and ((ta == "string") or (ta == "number"))) then
      return (a < b)
    else
      local dta = type_order[a]


@@ 192,7 181,6 @@ package.preload["fennelview"] = package.preload["fennelview"] or function(...)
      end
    end
  end
  pcall(function() require("fennel").metadata:setall(sort_keys, "fnl/arglist", {"a", "b"}) end)
  local function get_sequence_length(t)
    local len = 1
    for i in ipairs(t) do


@@ 200,7 188,6 @@ package.preload["fennelview"] = package.preload["fennelview"] or function(...)
    end
    return len
  end
  pcall(function() require("fennel").metadata:setall(get_sequence_length, "fnl/arglist", {"t"}) end)
  local function get_nonsequential_keys(t)
    local keys = {}
    local sequence_length = get_sequence_length(t)


@@ 212,7 199,6 @@ package.preload["fennelview"] = package.preload["fennelview"] or function(...)
    table.sort(keys, sort_keys)
    return keys, sequence_length
  end
  pcall(function() require("fennel").metadata:setall(get_nonsequential_keys, "fnl/arglist", {"t"}) end)
  local function count_table_appearances(t, appearances)
    if (type(t) == "table") then
      if not appearances[t] then


@@ 221,15 207,12 @@ package.preload["fennelview"] = package.preload["fennelview"] or function(...)
          count_table_appearances(k, appearances)
          count_table_appearances(v, appearances)
        end
      end
    else
      if (t and (t == t)) then
      else
        appearances[t] = ((appearances[t] or 0) + 1)
      end
    end
    return appearances
  end
  pcall(function() require("fennel").metadata:setall(count_table_appearances, "fnl/arglist", {"t", "appearances"}) end)
  local put_value = nil
  local function puts(self, ...)
    for _, v in ipairs({...}) do


@@ 237,15 220,12 @@ package.preload["fennelview"] = package.preload["fennelview"] or function(...)
    end
    return nil
  end
  pcall(function() require("fennel").metadata:setall(puts, "fnl/arglist", {"self", "..."}) end)
  local function tabify(self)
    return puts(self, "\n", (self.indent):rep(self.level))
  end
  pcall(function() require("fennel").metadata:setall(tabify, "fnl/arglist", {"self"}) end)
  local function already_visited_3f(self, v)
    return (self.ids[v] ~= nil)
  end
  pcall(function() require("fennel").metadata:setall(already_visited_3f, "fnl/arglist", {"self", "v"}) end)
  local function get_id(self, v)
    local id = self.ids[v]
    if not id then


@@ 256,7 236,6 @@ package.preload["fennelview"] = package.preload["fennelview"] or function(...)
    end
    return tostring(id)
  end
  pcall(function() require("fennel").metadata:setall(get_id, "fnl/arglist", {"self", "v"}) end)
  local function put_sequential_table(self, t, len)
    puts(self, "[")
    self.level = (self.level + 1)


@@ 270,7 249,6 @@ package.preload["fennelview"] = package.preload["fennelview"] or function(...)
    self.level = (self.level - 1)
    return puts(self, "]")
  end
  pcall(function() require("fennel").metadata:setall(put_sequential_table, "fnl/arglist", {"self", "t", "len"}) end)
  local function put_key(self, k)
    if ((type(k) == "string") and k:find("^[-%w?\\^_!$%&*+./@:|<=>]+$")) then
      return puts(self, ":", k)


@@ 278,7 256,6 @@ package.preload["fennelview"] = package.preload["fennelview"] or function(...)
      return put_value(self, k)
    end
  end
  pcall(function() require("fennel").metadata:setall(put_key, "fnl/arglist", {"self", "k"}) end)
  local function put_kv_table(self, t, ordered_keys)
    puts(self, "{")
    self.level = (self.level + 1)


@@ 302,7 279,6 @@ package.preload["fennelview"] = package.preload["fennelview"] or function(...)
    end
    return puts(self, "}")
  end
  pcall(function() require("fennel").metadata:setall(put_kv_table, "fnl/arglist", {"self", "t", "ordered-keys"}) end)
  local function put_table(self, t)
    local metamethod = nil
    local function _1_()


@@ 320,7 296,7 @@ package.preload["fennelview"] = package.preload["fennelview"] or function(...)
    end
    metamethod = (self["metamethod?"] and _1_())
    if (already_visited_3f(self, t) and self["detect-cycles?"]) then
      return puts(self, "#<table ", get_id(self, t), ">")
      return puts(self, "#<table @", get_id(self, t), ">")
    elseif (self.level >= self.depth) then
      return puts(self, "{...}")
    elseif metamethod then


@@ 329,16 305,17 @@ package.preload["fennelview"] = package.preload["fennelview"] or function(...)
      local non_seq_keys, len = get_nonsequential_keys(t)
      local id = get_id(self, t)
      if ((1 < (self.appearances[t] or 0)) and self["detect-cycles?"]) then
        return puts(self, "#<table", id, ">")
      elseif ((#non_seq_keys == 0) and (#t == 0)) then
        local function _2_()
        puts(self, "@", id)
      end
      if ((#non_seq_keys == 0) and (#t == 0)) then
        local function _3_()
          if self["empty-as-square"] then
            return "[]"
          else
            return "{}"
          end
        end
        return puts(self, _2_())
        return puts(self, _3_())
      elseif (#non_seq_keys == 0) then
        return put_sequential_table(self, t, len)
      elseif "else" then


@@ 346,26 323,34 @@ package.preload["fennelview"] = package.preload["fennelview"] or function(...)
      end
    end
  end
  pcall(function() require("fennel").metadata:setall(put_table, "fnl/arglist", {"self", "t"}) end)
  local function _0_(self, v)
    local tv = type(v)
    if (tv == "string") then
      return puts(self, view_quote(escape(v)))
    elseif ((tv == "number") or (tv == "boolean") or (tv == "nil")) then
      return puts(self, tostring(v))
    elseif (tv == "table") then
      return put_table(self, v)
    elseif "else" then
      return puts(self, "#<", tostring(v), ">")
    else
      local _2_
      do
        local _1_0 = getmetatable(v)
        if _1_0 then
          _2_ = _1_0.__fennelview
        else
          _2_ = _1_0
        end
      end
      if ((tv == "table") or ((tv == "userdata") and (nil ~= _2_))) then
        return put_table(self, v)
      elseif "else" then
        return puts(self, "#<", tostring(v), ">")
      end
    end
  end
  pcall(function() require("fennel").metadata:setall(_0_, "fnl/arglist", {"self", "v"}) end)
  put_value = _0_
  local function one_line(str)
    local ret = str:gsub("\n", " "):gsub("%[ ", "["):gsub(" %]", "]"):gsub("%{ ", "{"):gsub(" %}", "}"):gsub("%( ", "("):gsub(" %)", ")")
    return ret
  end
  pcall(function() require("fennel").metadata:setall(one_line, "fnl/arglist", {"str"}) end)
  local function fennelview(x, options)
    local options0 = (options or {})
    local inspector = nil


@@ 388,3289 373,3223 @@ package.preload["fennelview"] = package.preload["fennelview"] or function(...)
      return str
    end
  end
  pcall(function() require("fennel").metadata:setall(fennelview, "fnl/arglist", {"x", "options"}, "fnl/docstring", "Return a string representation of x.\n\nCan take an options table with these keys:\n* :one-line (boolean: default: false) keep the output string as a one-liner\n* :depth (number, default: 128) limit how many levels to go (default: 128)\n* :indent (string, default: \"  \") use this string to indent each level\n* :detect-cycles? (boolean, default: true) don't try to traverse a looping table\n* :metamethod? (boolean: default: true) use the __fennelview metamethod if found\n* :table-edges (boolean: default: true) put {} table brackets on their own line\n* :empty-as-square (boolean: default: false) render empty tables as [], not {}\n\nThe __fennelview metamethod should take the table being serialized as its first\nargument and a function as its second arg which can be used on table elements to\ncontinue the fennelview process on them.") end)
  return fennelview
end
package.preload["fennelfriend"] = package.preload["fennelfriend"] or function(...)
  local function ast_source(ast)
    local m = getmetatable(ast)
    if (m and m.filename and m.line and m) then
      return m
    else
      return ast
local fennel = nil
package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
  local utils = require("fennel.utils")
  local parser = require("fennel.parser")
  local compiler = require("fennel.compiler")
  local specials = require("fennel.specials")
  local function default_read_chunk(parser_state)
    local function _0_()
      if (0 < parser_state["stack-size"]) then
        return ".."
      else
        return ">> "
      end
    end
    io.write(_0_())
    io.flush()
    local input = io.read()
    return (input and (input .. "\n"))
  end
  pcall(function() require("fennel").metadata:setall(ast_source, "fnl/arglist", {"ast"}) end)
  local suggestions = {["$ and $... in hashfn are mutually exclusive"] = {"modifying the hashfn so it only contains $... or $, $1, $2, $3, etc"}, ["can't start multisym segment with a digit"] = {"removing the digit", "adding a non-digit before the digit"}, ["cannot call literal value"] = {"checking for typos", "checking for a missing function name"}, ["could not compile value of type "] = {"debugging the macro you're calling not to return a coroutine or userdata"}, ["could not read number (.*)"] = {"removing the non-digit character", "beginning the identifier with a non-digit if it is not meant to be a number"}, ["expected a function.* to call"] = {"removing the empty parentheses", "using square brackets if you want an empty table"}, ["expected binding table"] = {"placing a table here in square brackets containing identifiers to bind"}, ["expected body expression"] = {"putting some code in the body of this form after the bindings"}, ["expected each macro to be function"] = {"ensuring that the value for each key in your macros table contains a function", "avoid defining nested macro tables"}, ["expected even number of name/value bindings"] = {"finding where the identifier or value is missing"}, ["expected even number of values in table literal"] = {"removing a key", "adding a value"}, ["expected local"] = {"looking for a typo", "looking for a local which is used out of its scope"}, ["expected macros to be table"] = {"ensuring your macro definitions return a table"}, ["expected parameters"] = {"adding function parameters as a list of identifiers in brackets"}, ["expected rest argument before last parameter"] = {"moving & to right before the final identifier when destructuring"}, ["expected symbol for function parameter: (.*)"] = {"changing %s to an identifier instead of a literal value"}, ["expected var (.*)"] = {"declaring %s using var instead of let/local", "introducing a new local instead of changing the value of %s"}, ["expected vararg as last parameter"] = {"moving the \"...\" to the end of the parameter list"}, ["expected whitespace before opening delimiter"] = {"adding whitespace"}, ["global (.*) conflicts with local"] = {"renaming local %s"}, ["illegal character: (.)"] = {"deleting or replacing %s", "avoiding reserved characters like \", \\, ', ~, ;, @, `, and comma"}, ["local (.*) was overshadowed by a special form or macro"] = {"renaming local %s"}, ["macro not found in macro module"] = {"checking the keys of the imported macro module's returned table"}, ["macro tried to bind (.*) without gensym"] = {"changing to %s# when introducing identifiers inside macros"}, ["malformed multisym"] = {"ensuring each period or colon is not followed by another period or colon"}, ["may only be used at compile time"] = {"moving this to inside a macro if you need to manipulate symbols/lists", "using square brackets instead of parens to construct a table"}, ["method must be last component"] = {"using a period instead of a colon for field access", "removing segments after the colon", "making the method call, then looking up the field on the result"}, ["mismatched closing delimiter (.), expected (.)"] = {"replacing %s with %s", "deleting %s", "adding matching opening delimiter earlier"}, ["multisym method calls may only be in call position"] = {"using a period instead of a colon to reference a table's fields", "putting parens around this"}, ["unable to bind (.*)"] = {"replacing the %s with an identifier"}, ["unexpected closing delimiter (.)"] = {"deleting %s", "adding matching opening delimiter earlier"}, ["unexpected multi symbol (.*)"] = {"removing periods or colons from %s"}, ["unexpected vararg"] = {"putting \"...\" at the end of the fn parameters if the vararg was intended"}, ["unknown global in strict mode: (.*)"] = {"looking to see if there's a typo", "using the _G table instead, eg. _G.%s if you really want a global", "moving this code to somewhere that %s is in scope", "binding %s as a local in the scope of this code"}, ["unused local (.*)"] = {"fixing a typo so %s is used", "renaming the local to _%s"}, ["use of global (.*) is aliased by a local"] = {"renaming local %s", "refer to the global using _G.%s instead of directly"}}
  local unpack = (_G.unpack or table.unpack)
  local function suggest(msg)
    local suggestion = nil
    for pat, sug in pairs(suggestions) do
      local matches = {msg:match(pat)}
      if (0 < #matches) then
        if ("table" == type(sug)) then
          local out = {}
          for _, s in ipairs(sug) do
            table.insert(out, s:format(unpack(matches)))
  local function default_on_values(xs)
    io.write(table.concat(xs, "\9"))
    return io.write("\n")
  end
  local function default_on_error(errtype, err, lua_source)
    local function _1_()
      local _0_0 = errtype
      if (_0_0 == "Lua Compile") then
        return ("Bad code generated - likely a bug with the compiler:\n" .. "--- Generated Lua Start ---\n" .. lua_source .. "--- Generated Lua End ---\n")
      elseif (_0_0 == "Runtime") then
        return (compiler.traceback(err, 4) .. "\n")
      else
        local _ = _0_0
        return ("%s error: %s\n"):format(errtype, tostring(err))
      end
    end
    return io.write(_1_())
  end
  local save_source = table.concat({"local ___i___ = 1", "while true do", " local name, value = debug.getlocal(1, ___i___)", " if(name and name ~= \"___i___\") then", " ___replLocals___[name] = value", " ___i___ = ___i___ + 1", " else break end end"}, "\n")
  local function splice_save_locals(env, lua_source)
    env.___replLocals___ = (env.___replLocals___ or {})
    local spliced_source = {}
    local bind = "local %s = ___replLocals___['%s']"
    for line in lua_source:gmatch("([^\n]+)\n?") do
      table.insert(spliced_source, line)
    end
    for name in pairs(env.___replLocals___) do
      table.insert(spliced_source, 1, bind:format(name, name))
    end
    if ((1 < #spliced_source) and (spliced_source[#spliced_source]):match("^ *return .*$")) then
      table.insert(spliced_source, #spliced_source, save_source)
    end
    return table.concat(spliced_source, "\n")
  end
  local commands = {}
  local function command_3f(input)
    return input:match("^%s*,")
  end
  commands.help = function(_, _0, on_values)
    return on_values({"Welcome to Fennel.\nThis is the REPL where you can enter code to be evaluated.\nYou can also run these repl commands:\n\n  ,help - show this message\n  ,reload module-name - reload the specified module\n  ,reset - erase all repl-local scope\n  ,exit - leave the repl\n\nUse (doc something) to see descriptions for individual macros and special forms.\n\nFor more information about the language, see https://fennel-lang.org/reference"})
  end
  local function reload(module_name, env, on_values, on_error)
    local _0_0, _1_0 = pcall(specials["load-code"]("return require(...)", env), module_name)
    if ((_0_0 == true) and (nil ~= _1_0)) then
      local old = _1_0
      local _ = nil
      package.loaded[module_name] = nil
      _ = nil
      local ok, new = pcall(require, module_name)
      local new0 = nil
      if not ok then
        on_values(new)
        new0 = old
      else
        new0 = new
      end
      if ((type(old) == "table") and (type(new0) == "table")) then
        for k, v in pairs(new0) do
          old[k] = v
        end
        for k in pairs(old) do
          if (nil == new0[k]) then
            old[k] = nil
          end
          suggestion = out
        else
          suggestion = sug(matches)
        end
        package.loaded[module_name] = old
      end
      return on_values({"ok"})
    elseif ((_0_0 == false) and (nil ~= _1_0)) then
      local msg = _1_0
      local function _3_()
        local _2_0 = msg:gsub("\n.*", "")
        return _2_0
      end
      return on_error("Runtime", _3_())
    end
    return suggestion
  end
  pcall(function() require("fennel").metadata:setall(suggest, "fnl/arglist", {"msg"}) end)
  local function read_line_from_file(filename, line)
    local bytes = 0
    local f = assert(io.open(filename))
    local _ = nil
    for _0 = 1, (line - 1) do
      bytes = (bytes + 1 + #f:read())
  commands.reload = function(read, env, on_values, on_error)
    local _0_0, _1_0, _2_0 = pcall(read)
    if ((_0_0 == true) and (_1_0 == true) and (nil ~= _2_0)) then
      local module_sym = _2_0
      return reload(tostring(module_sym), env, on_values, on_error)
    elseif ((_0_0 == false) and true and true) then
      local _3fparse_ok = _1_0
      local _3fmsg = _2_0
      return on_error("Parse", (_3fmsg or _3fparse_ok))
    end
    _ = nil
    local codeline = f:read()
    f:close()
    return codeline, bytes
  end
  pcall(function() require("fennel").metadata:setall(read_line_from_file, "fnl/arglist", {"filename", "line"}) end)
  local function read_line_from_source(source, line)
    local lines, bytes, codeline = 0, 0
    for this_line, newline in string.gmatch((source .. "\n"), "(.-)(\13?\n)") do
      lines = (lines + 1)
      if (lines == line) then
        codeline = this_line
        break
  commands.reset = function(_, env, on_values)
    env.___replLocals___ = {}
    return on_values({"ok"})
  end
  local function run_command(input, read, loop, env, on_values, on_error)
    local command_name = input:match(",([^%s/]+)")
    do
      local _0_0 = commands[command_name]
      if (nil ~= _0_0) then
        local command = _0_0
        command(read, env, on_values, on_error)
      else
        local _ = _0_0
        if ("exit" ~= command_name) then
          on_values({"Unknown command", command_name})
        end
      end
      bytes = (bytes + #newline + #this_line)
    end
    return codeline, bytes
    if ("exit" ~= command_name) then
      return loop()
    end
  end
  pcall(function() require("fennel").metadata:setall(read_line_from_source, "fnl/arglist", {"source", "line"}) end)
  local function read_line(filename, line, source)
    if source then
      return read_line_from_source(source, line)
    else
      return read_line_from_file(filename, line)
  local function completer(env, scope, text)
    local matches = {}
    local input_fragment = text:gsub(".*[%s)(]+", "")
    local function add_partials(input, tbl, prefix)
      for k in utils.allpairs(tbl) do
        local k0 = nil
        if ((tbl == env) or (tbl == env.___replLocals___)) then
          k0 = scope.unmanglings[k]
        else
          k0 = k
        end
        if ((#matches < 2000) and (type(k0) == "string") and (input == k0:sub(0, #input))) then
          table.insert(matches, (prefix .. k0))
        end
      end
      return nil
    end
    local function add_matches(input, tbl, prefix)
      local prefix0 = nil
      if prefix then
        prefix0 = (prefix .. ".")
      else
        prefix0 = ""
      end
      if not input:find("%.") then
        return add_partials(input, tbl, prefix0)
      else
        local head, tail = input:match("^([^.]+)%.(.*)")
        local raw_head = nil
        if ((tbl == env) or (tbl == env.___replLocals___)) then
          raw_head = scope.manglings[head]
        else
          raw_head = head
        end
        if (type(tbl[raw_head]) == "table") then
          return add_matches(tail, tbl[raw_head], (prefix0 .. head))
        end
      end
    end
    add_matches(input_fragment, (scope.specials or {}))
    add_matches(input_fragment, (scope.macros or {}))
    add_matches(input_fragment, (env.___replLocals___ or {}))
    add_matches(input_fragment, env)
    add_matches(input_fragment, (env._ENV or env._G or {}))
    return matches
  end
  pcall(function() require("fennel").metadata:setall(read_line, "fnl/arglist", {"filename", "line", "source"}) end)
  local function friendly_msg(msg, _0_0, source)
    local _1_ = _0_0
    local byteend = _1_["byteend"]
    local bytestart = _1_["bytestart"]
    local filename = _1_["filename"]
    local line = _1_["line"]
    local ok, codeline, bol, eol = pcall(read_line, filename, line, source)
    local suggestions0 = suggest(msg)
    local out = {msg, ""}
    if (ok and codeline) then
      table.insert(out, codeline)
  local function repl(options)
    local old_root_options = utils.root.options
    local env = nil
    if options.env then
      env = specials["wrap-env"](options.env)
    else
      env = setmetatable({}, {__index = (_G._ENV or _G)})
    end
    if (ok and codeline and bytestart and byteend) then
      table.insert(out, (string.rep(" ", (bytestart - bol - 1)) .. "^" .. string.rep("^", math.min((byteend - bytestart), ((bol + #codeline) - bytestart)))))
    local save_locals_3f = ((options.saveLocals ~= false) and env.debug and env.debug.getlocal)
    local opts = {}
    local _ = nil
    for k, v in pairs(options) do
      opts[k] = v
    end
    if (ok and codeline and bytestart and not byteend) then
      table.insert(out, (string.rep("-", (bytestart - bol - 1)) .. "^"))
      table.insert(out, "")
    _ = nil
    local read_chunk = (opts.readChunk or default_read_chunk)
    local on_values = (opts.onValues or default_on_values)
    local on_error = (opts.onError or default_on_error)
    local pp = (opts.pp or tostring)
    local byte_stream, clear_stream = parser.granulate(read_chunk)
    local chars = {}
    local read, reset = nil, nil
    local function _1_(parser_state)
      local c = byte_stream(parser_state)
      table.insert(chars, c)
      return c
    end
    if suggestions0 then
      for _, suggestion in ipairs(suggestions0) do
        table.insert(out, ("* Try %s."):format(suggestion))
    read, reset = parser.parser(_1_)
    local scope = compiler["make-scope"]()
    opts.useMetadata = (options.useMetadata ~= false)
    if (opts.allowedGlobals == nil) then
      opts.allowedGlobals = specials["current-global-names"](opts.env)
    end
    if opts.registerCompleter then
      local function _3_(...)
        return completer(env, scope, ...)
      end
      opts.registerCompleter(_3_)
    end
    return table.concat(out, "\n")
  end
  pcall(function() require("fennel").metadata:setall(friendly_msg, "fnl/arglist", {"msg", "#<table>", "source"}) end)
  local function assert_compile(condition, msg, ast, source)
    if not condition then
      local _1_ = ast_source(ast)
      local filename = _1_["filename"]
      local line = _1_["line"]
      error(friendly_msg(("Compile error in %s:%s\n  %s"):format((filename or "unknown"), (line or "?"), msg), ast_source(ast), source), 0)
    local function print_values(...)
      local vals = {...}
      local out = {}
      env._, env.__ = vals[1], vals
      for i = 1, select("#", ...) do
        table.insert(out, pp(vals[i]))
      end
      return on_values(out)
    end
    return condition
  end
  pcall(function() require("fennel").metadata:setall(assert_compile, "fnl/arglist", {"condition", "msg", "ast", "source"}, "fnl/docstring", "A drop-in replacement for the internal assertCompile with friendly messages.") end)
  local function parse_error(msg, filename, line, bytestart, source)
    return error(friendly_msg(("Parse error in %s:%s\n  %s"):format(filename, line, msg), {bytestart = bytestart, filename = filename, line = line}, source), 0)
  end
  pcall(function() require("fennel").metadata:setall(parse_error, "fnl/arglist", {"msg", "filename", "line", "bytestart", "source"}, "fnl/docstring", "A drop-in replacement for the internal parseError with friendly messages.") end)
  return {["assert-compile"] = assert_compile, ["parse-error"] = parse_error}
end
local fennel = nil
package.preload["fennel"] = package.preload["fennel"] or function(...)
  --[[
  Copyright (c) 2016-2020 Calvin Rose and contributors
  Permission is hereby granted, free of charge, to any person obtaining a copy of
  this software and associated documentation files (the "Software"), to deal in
  the Software without restriction, including without limitation the rights to
  use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
  the Software, and to permit persons to whom the Software is furnished to do so,
  subject to the following conditions:
  The above copyright notice and this permission notice shall be included in all
  copies or substantial portions of the Software.
  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
  FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
  COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
  IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
  CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  ]]
  
  -- Make global variables local.
  local setmetatable = setmetatable
  local getmetatable = getmetatable
  local type = type
  local assert = assert
  local pairs = pairs
  local ipairs = ipairs
  local tostring = tostring
  local unpack = _G.unpack or table.unpack
  
  --
  -- Main Types and support functions
  --
  
  local utils = (function()
      -- Like pairs, but gives consistent ordering every time. On 5.1, 5.2, and LuaJIT
      -- pairs is already stable, but on 5.3 every run gives different ordering.
      local function stablepairs(t)
          local keys, succ = {}, {}
          for k in pairs(t) do table.insert(keys, k) end
          table.sort(keys, function(a, b) return tostring(a) < tostring(b) end)
          for i,k in ipairs(keys) do succ[k] = keys[i+1] end
          local function stablenext(tbl, idx)
              if idx == nil then return keys[1], tbl[keys[1]] end
              return succ[idx], tbl[succ[idx]]
          end
          return stablenext, t, nil
      end
  
      -- Map function f over sequential table t, removing values where f returns nil.
      -- Optionally takes a target table to insert the mapped values into.
      local function map(t, f, out)
          out = out or {}
          if type(f) ~= "function" then local s = f f = function(x) return x[s] end end
          for _,x in ipairs(t) do
              local v = f(x)
              if v then table.insert(out, v) end
          end
          return out
      end
  
      -- Map function f over key/value table t, similar to above, but it can return a
      -- sequential table if f returns a single value or a k/v table if f returns two.
      -- Optionally takes a target table to insert the mapped values into.
      local function kvmap(t, f, out)
          out = out or {}
          if type(f) ~= "function" then local s = f f = function(x) return x[s] end end
          for k,x in stablepairs(t) do
              local korv, v = f(k, x)
              if korv and not v then table.insert(out, korv) end
              if korv and v then out[korv] = v end
          end
          return out
      end
  
      -- Returns a shallow copy of its table argument. Returns an empty table on nil.
      local function copy(from)
         local to = {}
         for k, v in pairs(from or {}) do to[k] = v end
         return to
      end
  
      -- Like pairs, but if the table has an __index metamethod, it will recurisvely
      -- traverse upwards, skipping duplicates, to iterate all inherited properties
      local function allpairs(t)
          assert(type(t) == 'table', 'allpairs expects a table')
          local seen = {}
          local function allpairsNext(_, state)
              local nextState, value = next(t, state)
              if seen[nextState] then
                  return allpairsNext(nil, nextState)
              elseif nextState then
                  seen[nextState] = true
                  return nextState, value
              end
              local meta = getmetatable(t)
              if meta and meta.__index then
                  t = meta.__index
                  return allpairsNext(t)
              end
          end
          return allpairsNext
      end
  
      local function deref(self) return self[1] end
  
      local nilSym -- haven't defined sym yet; create this later
  
      local function listToString(self, tostring2)
          local safe, max = {}, 0
          for k in pairs(self) do if type(k) == "number" and k>max then max=k end end
          for i=1,max do -- table.maxn was removed from Lua 5.3 for some reason???
              safe[i] = self[i] == nil and nilSym or self[i]
          end
          return '(' .. table.concat(map(safe, tostring2 or tostring), ' ', 1, max) .. ')'
      end
  
      local SYMBOL_MT = { 'SYMBOL', __tostring = deref, __fennelview = deref }
      local EXPR_MT = { 'EXPR', __tostring = deref }
      local VARARG = setmetatable({ '...' },
          { 'VARARG', __tostring = deref, __fennelview = deref })
      local LIST_MT = { 'LIST', __tostring = listToString, __fennelview = listToString }
      local SEQUENCE_MARKER = { 'SEQUENCE' }
  
      -- Safely load an environment variable
      local getenv = os and os.getenv or function() return nil end
  
      local pathTable = {"./?.fnl", "./?/init.fnl"}
      table.insert(pathTable, getenv("FENNEL_PATH"))
  
      local function debugOn(flag)
          local level = getenv("FENNEL_DEBUG") or ""
          return level == "all" or level:find(flag)
      end
  
      -- Create a new list. Lists are a compile-time construct in Fennel; they are
      -- represented as tables with a special marker metatable. They only come from
      -- the parser, and they represent code which comes from reading a paren form;
      -- they are specifically not cons cells.
      local function list(...)
          return setmetatable({...}, LIST_MT)
      end
  
      -- Create a new symbol. Symbols are a compile-time construct in Fennel and are
      -- not exposed outside the compiler. Symbols have source data describing what
      -- file, line, etc that they came from.
      local function sym(str, scope, source)
          local s = {str, scope = scope}
          for k, v in pairs(source or {}) do
              if type(k) == 'string' then s[k] = v end
          end
          return setmetatable(s, SYMBOL_MT)
      end
  
      nilSym = sym("nil")
  
      -- Create a new sequence. Sequences are tables that come from the parser when
      -- it encounters a form with square brackets. They are treated as regular tables
      -- except when certain macros need to look for binding forms, etc specifically.
      local function sequence(...)
          -- can't use SEQUENCE_MT directly as the sequence metatable like we do with
          -- the other types without giving up the ability to set source metadata
          -- on a sequence, (which we need for error reporting) so embed a marker
          -- value in the metatable instead.
          return setmetatable({...}, {sequence=SEQUENCE_MARKER})
      end
  
      -- Create a new expr
      -- etype should be one of
      --   "literal": literals like numbers, strings, nil, true, false
      --   "expression": Complex strings of Lua code, may have side effects, etc
      --                 but is an expression
      --   "statement": Same as expression, but is also a valid statement
      --                (function calls).
      --   "vargs": varargs symbol
      --   "sym": symbol reference
      local function expr(strcode, etype)
          return setmetatable({ strcode, type = etype }, EXPR_MT)
      end
  
      local function varg()
          return VARARG
      end
  
      local function isExpr(x)
          return type(x) == 'table' and getmetatable(x) == EXPR_MT and x
      end
  
      local function isVarg(x)
          return x == VARARG and x
      end
  
      -- Checks if an object is a List. Returns the object if is a List.
      local function isList(x)
          return type(x) == 'table' and getmetatable(x) == LIST_MT and x
      end
  
      -- Checks if an object is a symbol. Returns the object if it is a symbol.
      local function isSym(x)
          return type(x) == 'table' and getmetatable(x) == SYMBOL_MT and x
      end
  
      -- Checks if an object any kind of table, EXCEPT list or symbol
      local function isTable(x)
          return type(x) == 'table' and
              x ~= VARARG and
              getmetatable(x) ~= LIST_MT and getmetatable(x) ~= SYMBOL_MT and x
      end
  
      -- Checks if an object is a sequence (created with a [] literal)
      local function isSequence(x)
          local mt = type(x) == "table" and getmetatable(x)
          return mt and mt.sequence == SEQUENCE_MARKER and x
      end
  
      -- A multi symbol is a symbol that is actually composed of
      -- two or more symbols using the dot syntax. The main differences
      -- from normal symbols is that they cannot be declared local, and
      -- they may have side effects on invocation (metatables)
      local function isMultiSym(str)
          if isSym(str) then
              return isMultiSym(tostring(str))
          end
          if type(str) ~= 'string' then return end
          local parts = {}
          for part in str:gmatch('[^%.%:]+[%.%:]?') do
              local lastChar = part:sub(-1)
              if lastChar == ":" then
                  parts.multiSymMethodCall = true
              end
              if lastChar == ":" or lastChar == "." then
                  parts[#parts + 1] = part:sub(1, -2)
    local function loop()
      for k in pairs(chars) do
        chars[k] = nil
      end
      local ok, parse_ok_3f, x = pcall(read)
      local src_string = string.char((_G.unpack or table.unpack)(chars))
      utils.root.options = opts
      if not ok then
        on_error("Parse", parse_ok_3f)
        clear_stream()
        reset()
        return loop()
      elseif command_3f(src_string) then
        return run_command(src_string, read, loop, env, on_values, on_error)
      else
        if parse_ok_3f then
          do
            local _4_0, _5_0 = pcall(compiler.compile, x, {["assert-compile"] = opts["assert-compile"], ["parse-error"] = opts["parse-error"], correlate = opts.correlate, moduleName = opts.moduleName, scope = scope, source = src_string, useMetadata = opts.useMetadata})
            if ((_4_0 == false) and (nil ~= _5_0)) then
              local msg = _5_0
              clear_stream()
              on_error("Compile", msg)
            elseif ((_4_0 == true) and (nil ~= _5_0)) then
              local src = _5_0
              local src0 = nil
              if save_locals_3f then
                src0 = splice_save_locals(env, src)
              else
                  parts[#parts + 1] = part
              end
          end
          return #parts > 0 and
              (str:match('%.') or str:match(':')) and
              (not str:match('%.%.')) and
              str:byte() ~= string.byte '.' and
              str:byte(-1) ~= string.byte '.' and
              parts
      end
  
      local function isQuoted(symbol) return symbol.quoted end
  
      -- Walks a tree (like the AST), invoking f(node, idx, parent) on each node.
      -- When f returns a truthy value, recursively walks the children.
      local walkTree = function(root, f, customIterator)
          local function walk(iterfn, parent, idx, node)
              if f(idx, node, parent) then
                  for k, v in iterfn(node) do walk(iterfn, node, k, v) end
                src0 = src
              end
          end
  
          walk(customIterator or pairs, nil, nil, root)
          return root
      end
  
      local luaKeywords = {
          'and', 'break', 'do', 'else', 'elseif', 'end', 'false', 'for',
          'function', 'if', 'in', 'local', 'nil', 'not', 'or', 'repeat', 'return',
          'then', 'true', 'until', 'while', 'goto'
      }
  
      for i, v in ipairs(luaKeywords) do luaKeywords[v] = i end
  
      local function isValidLuaIdentifier(str)
          return (str:match('^[%a_][%w_]*$') and not luaKeywords[str])
      end
  
      -- Certain options should always get propagated onwards when a function that
      -- has options calls down into compile.
      local propagatedOptions = {"allowedGlobals", "indent", "correlate",
                                 "useMetadata", "env"}
      local function propagateOptions(options, subopts)
          for _,name in ipairs(propagatedOptions) do subopts[name] = options[name] end
          return subopts
      end
  
      local root = {
          -- Top level compilation bindings.
          chunk=nil, scope=nil, options=nil,
  
          -- The root.reset function needs to be called at every exit point of the
          -- compiler including when there's a parse error or compiler
          -- error. This would be better done using dynamic scope, but we don't
          -- have dynamic scope, so we fake it by ensuring we call this at every
          -- exit point, including errors.
          reset=function() end,
  
          setReset=function(root)
              local chunk, scope, options = root.chunk, root.scope, root.options
              local oldResetRoot = root.reset -- this needs to nest!
              root.reset = function()
                  root.chunk, root.scope, root.options = chunk, scope, options
                  root.reset = oldResetRoot
              end
          end,
      }
  
      return {
          -- basic general table functions:
          stablepairs=stablepairs, allpairs=allpairs, map=map, kvmap=kvmap,
          copy=copy, walkTree=walkTree,
  
          -- AST functions:
          list=list, sym=sym, sequence=sequence, expr=expr, varg=varg,
          isVarg=isVarg, isList=isList, isSym=isSym, isTable=isTable,
          isSequence=isSequence, isMultiSym=isMultiSym, isQuoted=isQuoted,
          isExpr=isExpr, deref=deref,
  
          -- other functions:
          isValidLuaIdentifier=isValidLuaIdentifier, luaKeywords=luaKeywords,
          propagateOptions=propagateOptions, debugOn=debugOn,
          root=root, path=table.concat(pathTable, ";"),}
  end)()
  
  --
  -- Parser
  --
  
  local parser = (function()
      -- Convert a stream of chunks to a stream of bytes.
      -- Also returns a second function to clear the buffer in the byte stream
      local function granulate(getchunk)
          local c = ''
          local index = 1
          local done = false
          return function (parserState)
              if done then return nil end
              if index <= #c then
                  local b = c:byte(index)
                  index = index + 1
                  return b
              else
                  c = getchunk(parserState)
                  if not c or c == '' then
                      done = true
                      return nil
                  end
                  index = 2
                  return c:byte(1)
              local _7_0, _8_0 = pcall(specials["load-code"], src0, env)
              if ((_7_0 == false) and (nil ~= _8_0)) then
                local msg = _8_0
                clear_stream()
                on_error("Lua Compile", msg, src0)
              elseif (true and (nil ~= _8_0)) then
                local _0 = _7_0
                local chunk = _8_0
                local function _9_()
                  return print_values(chunk())
                end
                local function _10_(...)
                  return on_error("Runtime", ...)
                end
                xpcall(_9_, _10_)
              end
          end, function ()
              c = ''
            end
          end
          utils.root.options = old_root_options
          return loop()
        end
      end
  
      -- Convert a string into a stream of bytes
      local function stringStream(str)
          str=str:gsub("^#![^\n]*\n", "") -- remove shebang
          local index = 1
          return function()
              local r = str:byte(index)
              index = index + 1
              return r
          end
    end
    return loop()
  end
  return repl
end
package.preload["fennel.specials"] = package.preload["fennel.specials"] or function(...)
  local utils = require("fennel.utils")
  local parser = require("fennel.parser")
  local compiler = require("fennel.compiler")
  local unpack = (_G.unpack or table.unpack)
  local SPECIALS = compiler.scopes.global.specials
  local function wrap_env(env)
    local function _0_(_, key)
      if (type(key) == "string") then
        return env[compiler["global-unmangling"](key)]
      else
        return env[key]
      end
  
      -- Table of delimiter bytes - (, ), [, ], {, }
      -- Opener keys have closer as the value, and closers keys
      -- have true as their value.
      local delims = {
          [40] = 41,        -- (
          [41] = true,      -- )
          [91] = 93,        -- [
          [93] = true,      -- ]
          [123] = 125,      -- {
          [125] = true      -- }
      }
  
      local function iswhitespace(b)
          return b == 32 or (b >= 9 and b <= 13)
      end
  
      local function issymbolchar(b)
          return b > 32 and
              not delims[b] and
              b ~= 127 and -- "<BS>"
              b ~= 34 and -- "\""
              b ~= 39 and -- "'"
              b ~= 126 and -- "~"
              b ~= 59 and -- ";"
              b ~= 44 and -- ","
              b ~= 64 and -- "@"
              b ~= 96 -- "`"
      end
  
      local prefixes = { -- prefix chars substituted while reading
          [96] = 'quote', -- `
          [44] = 'unquote', -- ,
          [39] = 'quote', -- '
          [35] = 'hashfn' -- #
      }
  
      -- Parse one value given a function that
      -- returns sequential bytes. Will throw an error as soon
      -- as possible without getting more bytes on bad input. Returns
      -- if a value was read, and then the value read. Will return nil
      -- when input stream is finished.
      local function parser(getbyte, filename, options)
  
          -- Stack of unfinished values
          local stack = {}
  
          -- Provide one character buffer and keep
          -- track of current line and byte index
          local line = 1
          local byteindex = 0
          local lastb
          local function ungetb(ub)
              if ub == 10 then line = line - 1 end
              byteindex = byteindex - 1
              lastb = ub
          end
          local function getb()
              local r
              if lastb then
                  r, lastb = lastb, nil
              else
                  r = getbyte({ stackSize = #stack })
              end
              byteindex = byteindex + 1
              if r == 10 then line = line + 1 end
              return r
          end
  
          -- If you add new calls to this function, please update fenneldfriend.fnl
          -- as well to add suggestions for how to fix the new error.
          local function parseError(msg)
              local source = utils.root.options and utils.root.options.source
              utils.root.reset()
              local override = options and options["parse-error"]
              if override then override(msg, filename or "unknown", line or "?",
                                        byteindex, source) end
              return error(("Parse error in %s:%s: %s"):
                      format(filename or "unknown", line or "?", msg), 0)
          end
  
          -- Parse stream
          return function()
  
              -- Dispatch when we complete a value
              local done, retval
              local whitespaceSinceDispatch = true
              local function dispatch(v)
                  if #stack == 0 then
                      retval = v
                      done = true
                  elseif stack[#stack].prefix then
                      local stacktop = stack[#stack]
                      stack[#stack] = nil
                      return dispatch(utils.list(utils.sym(stacktop.prefix), v))
                  else
                      table.insert(stack[#stack], v)
                  end
                  whitespaceSinceDispatch = false
              end
  
              -- Throw nice error when we expect more characters
              -- but reach end of stream.
              local function badend()
                  local accum = utils.map(stack, "closer")
                  parseError(('expected closing delimiter%s %s'):format(
                      #stack == 1 and "" or "s",
                      string.char(unpack(accum))))
              end
  
              -- The main parse loop
              repeat
                  local b
  
                  -- Skip whitespace
                  repeat
                      b = getb()
                      if b and iswhitespace(b) then
                          whitespaceSinceDispatch = true
                      end
                  until not b or not iswhitespace(b)
                  if not b then
                      if #stack > 0 then badend() end
                      return nil
                  end
  
                  if b == 59 then -- ; Comment
                      repeat
                          b = getb()
                      until not b or b == 10 -- newline
                  elseif type(delims[b]) == 'number' then -- Opening delimiter
                      if not whitespaceSinceDispatch then
                          parseError('expected whitespace before opening delimiter '
                                         .. string.char(b))
                      end
                      table.insert(stack, setmetatable({
                          closer = delims[b],
                          line = line,
                          filename = filename,
                          bytestart = byteindex
                      }, getmetatable(utils.list())))
                  elseif delims[b] then -- Closing delimiter
                      if #stack == 0 then parseError('unexpected closing delimiter '
                                                         .. string.char(b)) end
                      local last = stack[#stack]
                      local val
                      if last.closer ~= b then
                          parseError('mismatched closing delimiter ' .. string.char(b) ..
                                     ', expected ' .. string.char(last.closer))
                      end
                      last.byteend = byteindex -- Set closing byte index
                      if b == 41 then -- ; )
                          val = last
                      elseif b == 93 then -- ; ]
                          val = utils.sequence(unpack(last))
                          -- for table literals we can store file/line/offset source
                          -- data in fields on the table itself, because the AST node
                          -- *is* the table, and the fields would show up in the
                          -- compiled output. keep them on the metatable instead.
                          for k,v in pairs(last) do getmetatable(val)[k]=v end
                      else -- ; }
                          if #last % 2 ~= 0 then
                              byteindex = byteindex - 1
                              parseError('expected even number of values in table literal')
                          end
                          val = {}
                          setmetatable(val, last) -- see note above about source data
                          for i = 1, #last, 2 do
                              if(tostring(last[i]) == ":" and utils.isSym(last[i + 1])
                                 and utils.isSym(last[i])) then
                                  last[i] = tostring(last[i + 1])
                              end
                              val[last[i]] = last[i + 1]
                          end
                      end
                      stack[#stack] = nil
                      dispatch(val)
                  elseif b == 34 then -- Quoted string
                      local state = "base"
                      local chars = {34}
                      stack[#stack + 1] = {closer = 34}
                      repeat
                          b = getb()
                          chars[#chars + 1] = b
                          if state == "base" then
                              if b == 92 then
                                  state = "backslash"
                              elseif b == 34 then
                                  state = "done"
                              end
                          else
                              -- state == "backslash"
                              state = "base"
                          end
                      until not b or (state == "done")
                      if not b then badend() end
                      stack[#stack] = nil
                      local raw = string.char(unpack(chars))
                      local formatted = raw:gsub("[\1-\31]", function (c)
                                                     return '\\' .. c:byte() end)
                      local loadFn = (loadstring or load)(('return %s'):format(formatted))
                      dispatch(loadFn())
                  elseif prefixes[b] then
                      -- expand prefix byte into wrapping form eg. '`a' into '(quote a)'
                      table.insert(stack, {
                          prefix = prefixes[b]
                      })
                      local nextb = getb()
                      if iswhitespace(nextb) then
                          if b == 35 then
                              stack[#stack] = nil
                              dispatch(utils.sym('#'))
                          else
                              parseError('invalid whitespace after quoting prefix')
                          end
                      end
                      ungetb(nextb)
                  elseif issymbolchar(b) or b == string.byte("~") then -- Try sym
                      local chars = {}
                      local bytestart = byteindex
                      repeat
                          chars[#chars + 1] = b
                          b = getb()
                      until not b or not issymbolchar(b)
                      if b then ungetb(b) end
                      local rawstr = string.char(unpack(chars))
                      if rawstr == 'true' then dispatch(true)
                      elseif rawstr == 'false' then dispatch(false)
                      elseif rawstr == '...' then dispatch(utils.varg())
                      elseif rawstr:match('^:.+$') then -- colon style strings
                          dispatch(rawstr:sub(2))
                      elseif rawstr:match("^~") and rawstr ~= "~=" then
                          -- for backwards-compatibility, special-case allowance
                          -- of ~= but all other uses of ~ are disallowed
                          parseError("illegal character: ~")
                      else
                          local forceNumber = rawstr:match('^%d')
                          local numberWithStrippedUnderscores = rawstr:gsub("_", "")
                          local x
                          if forceNumber then
                              x = tonumber(numberWithStrippedUnderscores) or
                                  parseError('could not read number "' .. rawstr .. '"')
                          else
                              x = tonumber(numberWithStrippedUnderscores)
                              if not x then
                                  if(rawstr:match("%.[0-9]")) then
                                      byteindex = (byteindex - #rawstr +
                                                       rawstr:find("%.[0-9]") + 1)
                                      parseError("can't start multisym segment " ..
                                                     "with a digit: ".. rawstr)
                                  elseif(rawstr:match("[%.:][%.:]") and
                                         rawstr ~= ".." and rawstr ~= '$...') then
                                      byteindex = (byteindex - #rawstr +
                                                       rawstr:find("[%.:][%.:]") + 1)
                                      parseError("malformed multisym: " .. rawstr)
                                  elseif(rawstr:match(":.+[%.:]")) then
                                      byteindex = (byteindex - #rawstr +
                                                       rawstr:find(":.+[%.:]"))
                                      parseError("method must be last component "
                                                     .. "of multisym: " .. rawstr)
                                  else
                                      x = utils.sym(rawstr, nil, {line = line,
                                                            filename = filename,
                                                            bytestart = bytestart,
                                                            byteend = byteindex,})
                                  end
                              end
                          end
                          dispatch(x)
                      end
                  else
                      parseError("illegal character: " .. string.char(b))
                  end
              until done
              return true, retval
          end, function ()
              stack = {}
          end
    end
    local function _1_(_, key, value)
      if (type(key) == "string") then
        env[compiler["global-unmangling"](key)] = value
        return nil
      else
        env[key] = value
        return nil
      end
      return { granulate=granulate, stringStream=stringStream, parser=parser }
  end)()
  
  --
  -- Compilation
  --
  
  local compiler = (function()
      local scopes = {}
  
      -- Create a new Scope, optionally under a parent scope. Scopes are compile time
      -- constructs that are responsible for keeping track of local variables, name
      -- mangling, and macros.  They are accessible to user code via the
      -- 'eval-compiler' special form (may change). They use metatables to implement
      -- nesting.
      local function makeScope(parent)
          if not parent then parent = scopes.global end
          return {
              unmanglings = setmetatable({}, {
                  __index = parent and parent.unmanglings
              }),
              manglings = setmetatable({}, {
                  __index = parent and parent.manglings
              }),
              specials = setmetatable({}, {
                  __index = parent and parent.specials
              }),
              macros = setmetatable({}, {
                  __index = parent and parent.macros
              }),
              symmeta = setmetatable({}, {
                  __index = parent and parent.symmeta
              }),
              includes = setmetatable({}, {
                  __index = parent and parent.includes
              }),
              refedglobals = setmetatable({}, {
                  __index = parent and parent.refedglobals
              }),
              autogensyms = {},
              parent = parent,
              vararg = parent and parent.vararg,
              depth = parent and ((parent.depth or 0) + 1) or 0,
              hashfn = parent and parent.hashfn
          }
      end
  
      -- Assert a condition and raise a compile error with line numbers. The ast arg
      -- should be unmodified so that its first element is the form being called.
      -- If you add new calls to this function, please update fenneldfriend.fnl
      -- as well to add suggestions for how to fix the new error.
      local function assertCompile(condition, msg, ast)
          local override = utils.root.options and utils.root.options["assert-compile"]
          if override then
              local source = utils.root.options and utils.root.options.source
              -- don't make custom handlers deal with resetting root; it's error-prone
              if not condition then utils.root.reset() end
              override(condition, msg, ast, source)
              -- should we fall thru to the default check, or should we allow the
              -- override to swallow the error?
          end
          if not condition then
              utils.root.reset()
              local m = getmetatable(ast)
              local filename = m and m.filename or ast.filename or "unknown"
              local line = m and m.line or ast.line or "?"
              -- if we use regular `assert' we can't provide the `level' argument of 0
              error(string.format("Compile error in '%s' %s:%s: %s",
                                  tostring(utils.isSym(ast[1]) and ast[1][1] or
                                               ast[1] or '()'),
                                  filename, line, msg), 0)
          end
          return condition
      end
  
      scopes.global = makeScope()
      scopes.global.vararg = true
      scopes.compiler = makeScope(scopes.global)
      scopes.macro = scopes.global -- used by gensym, in-scope?, etc
  
      -- Allow printing a string to Lua, also keep as 1 line.
      local serializeSubst = {
          ['\a'] = '\\a',
          ['\b'] = '\\b',
          ['\f'] = '\\f',
          ['\n'] = 'n',
          ['\t'] = '\\t',
          ['\v'] = '\\v'
      }
      local function serializeString(str)
          local s = ("%q"):format(str)
          s = s:gsub('.', serializeSubst):gsub("[\128-\255]", function(c)
              return "\\" .. c:byte()
          end)
          return s
      end
  
      -- Mangler for global symbols. Does not protect against collisions,
      -- but makes them unlikely. This is the mangling that is exposed to
      -- to the world.
      local function globalMangling(str)
          if utils.isValidLuaIdentifier(str) then
              return str
          end
          -- Use underscore as escape character
          return '__fnl_global__' .. str:gsub('[^%w]', function (c)
              return ('_%02x'):format(c:byte())
          end)
      end
  
      -- Reverse a global mangling. Takes a Lua identifier and
      -- returns the fennel symbol string that created it.
      local function globalUnmangling(identifier)
          local rest = identifier:match('^__fnl_global__(.*)$')
          if rest then
              local r = rest:gsub('_[%da-f][%da-f]', function (code)
                  return string.char(tonumber(code:sub(2), 16))
              end)
              return r -- don't return multiple values
          else
              return identifier
          end
    end
    local function _2_()
      local function putenv(k, v)
        local _3_
        if (type(k) == "string") then
          _3_ = compiler["global-unmangling"](k)
        else
          _3_ = k
        end
        return _3_, v
      end
  
      -- If there's a provided list of allowed globals, don't let references thru that
      -- aren't on the list. This list is set at the compiler entry points of compile
      -- and compileStream.
      local allowedGlobals
  
      local function globalAllowed(name)
          if not allowedGlobals then return true end
          for _, g in ipairs(allowedGlobals) do
              if g == name then return true end
          end
      return next, utils.kvmap(env, putenv), nil
    end
    return setmetatable({}, {__index = _0_, __newindex = _1_, __pairs = _2_})
  end
  local function current_global_names(env)
    return utils.kvmap((env or _G), compiler["global-unmangling"])
  end
  local function load_code(code, environment, filename)
    local environment0 = ((environment or _ENV) or _G)
    if (_G.setfenv and _G.loadstring) then
      local f = assert(_G.loadstring(code, filename))
      _G.setfenv(f, environment0)
      return f
    else
      return assert(load(code, filename, "t", environment0))
    end
  end
  local function doc_2a(tgt, name)
    if not tgt then
      return (name .. " not found")
    else
      local docstring = (((compiler.metadata):get(tgt, "fnl/docstring") or "#<undocumented>")):gsub("\n$", ""):gsub("\n", "\n  ")
      if (type(tgt) == "function") then
        local arglist = table.concat(((compiler.metadata):get(tgt, "fnl/arglist") or {"#<unknown-arguments>"}), " ")
        local _0_
        if (#arglist > 0) then
          _0_ = " "
        else
          _0_ = ""
        end
        return string.format("(%s%s%s)\n  %s", name, _0_, arglist, docstring)
      else
        return string.format("%s\n  %s", name, docstring)
      end
  
      -- Creates a symbol from a string by mangling it.
      -- ensures that the generated symbol is unique
      -- if the input string is unique in the scope.
      local function localMangling(str, scope, ast, tempManglings)
          local append = 0
          local mangling = str
          assertCompile(not utils.isMultiSym(str), 'unexpected multi symbol ' .. str, ast)
  
          -- Mapping mangling to a valid Lua identifier
          if utils.luaKeywords[mangling] or mangling:match('^%d') then
              mangling = '_' .. mangling
          end
          mangling = mangling:gsub('-', '_')
          mangling = mangling:gsub('[^%w_]', function (c)
              return ('_%02x'):format(c:byte())
          end)
  
          -- Prevent name collisions with existing symbols
          local raw = mangling
          while scope.unmanglings[mangling] do
              mangling = raw .. append
              append = append + 1
          end
  
          scope.unmanglings[mangling] = str
          local manglings = tempManglings or scope.manglings
          manglings[str] = mangling
          return mangling
      end
  
      -- Calling this function will mean that further
      -- compilation in scope will use these new manglings
      -- instead of the current manglings.
      local function applyManglings(scope, newManglings, ast)
          for raw, mangled in pairs(newManglings) do
              assertCompile(not scope.refedglobals[mangled],
              "use of global " .. raw .. " is aliased by a local", ast)
              scope.manglings[raw] = mangled
    end
  end
  local function doc_special(name, arglist, docstring)
    compiler.metadata[SPECIALS[name]] = {["fnl/arglist"] = arglist, ["fnl/docstring"] = docstring}
    return nil
  end
  local function compile_do(ast, scope, parent, start)
    local start0 = (start or 2)
    local len = #ast
    local sub_scope = compiler["make-scope"](scope)
    for i = start0, len do
      compiler.compile1(ast[i], sub_scope, parent, {nval = 0})
    end
    return nil
  end
  SPECIALS["do"] = function(ast, scope, parent, opts, start, chunk, sub_scope, pre_syms)
    local start0 = (start or 2)
    local sub_scope0 = (sub_scope or compiler["make-scope"](scope))
    local chunk0 = (chunk or {})
    local len = #ast
    local retexprs = {returned = true}
    local function compile_body(outer_target, outer_tail, outer_retexprs)
      if (len < start0) then
        compiler.compile1(nil, sub_scope0, chunk0, {tail = outer_tail, target = outer_target})
      else
        for i = start0, len do
          local subopts = {nval = (((i ~= len) and 0) or opts.nval), tail = (((i == len) and outer_tail) or nil), target = (((i == len) and outer_target) or nil)}
          local _ = utils["propagate-options"](opts, subopts)
          local subexprs = compiler.compile1(ast[i], sub_scope0, chunk0, subopts)
          if (i ~= len) then
            compiler["keep-side-effects"](subexprs, parent, nil, ast[i])
          end
        end
      end
  
      -- Combine parts of a symbol
      local function combineParts(parts, scope)
          local ret = scope.manglings[parts[1]] or globalMangling(parts[1])
          for i = 2, #parts do
              if utils.isValidLuaIdentifier(parts[i]) then
                  if parts.multiSymMethodCall and i == #parts then
                      ret = ret .. ':' .. parts[i]
                  else
                      ret = ret .. '.' .. parts[i]
                  end
              else
                  ret = ret .. '[' .. serializeString(parts[i]) .. ']'
              end
          end
          return ret
      end
  
      -- Generates a unique symbol in the scope.
      local function gensym(scope, base)
          local mangling
          local append = 0
          repeat
              mangling = (base or '') .. '_' .. append .. '_'
              append = append + 1
          until not scope.unmanglings[mangling]
          scope.unmanglings[mangling] = true
          return mangling
      end
  
      -- Generates a unique symbol in the scope based on the base name. Calling
      -- repeatedly with the same base and same scope will return existing symbol
      -- rather than generating new one.
      local function autogensym(base, scope)
          local parts = utils.isMultiSym(base)
          if(parts) then
              parts[1] = autogensym(parts[1], scope)
              return table.concat(parts, parts.multiSymMethodCall and ":" or ".")
          end
  
          if scope.autogensyms[base] then return scope.autogensyms[base] end
          local mangling = gensym(scope, base:sub(1, -2))
          scope.autogensyms[base] = mangling
          return mangling
      end
  
      -- Check if a binding is valid
      local function checkBindingValid(symbol, scope, ast)
          -- Check if symbol will be over shadowed by special
          local name = symbol[1]
          -- assertCompile(not scope.specials[name] and not scope.macros[name],
          --               ("local %s was overshadowed by a special form or macro")
          --                   :format(name), ast)
          assertCompile(not utils.isQuoted(symbol),
                        ("macro tried to bind %s without gensym"):format(name), symbol)
  
      end
  
      -- Declare a local symbol
      local function declareLocal(symbol, meta, scope, ast, tempManglings)
          checkBindingValid(symbol, scope, ast)
          local name = symbol[1]
          assertCompile(not utils.isMultiSym(name),
                        "unexpected multi symbol " .. name, ast)
          local mangling = localMangling(name, scope, ast, tempManglings)
          scope.symmeta[name] = meta
          return mangling
      end
  
      -- Convert symbol to Lua code. Will only work for local symbols
      -- if they have already been declared via declareLocal
      local function symbolToExpression(symbol, scope, isReference)
          local name = symbol[1]
          local multiSymParts = utils.isMultiSym(name)
          if scope.hashfn then
             if name == '$' then name = '$1' end
             if multiSymParts then
                if multiSymParts[1] == "$" then
                   multiSymParts[1] = "$1"
                   name = table.concat(multiSymParts, ".")
                end
             end
          end
          local parts = multiSymParts or {name}
          local etype = (#parts > 1) and "expression" or "sym"
          local isLocal = scope.manglings[parts[1]]
          if isLocal and scope.symmeta[parts[1]] then scope.symmeta[parts[1]].used = true end
          -- if it's a reference and not a symbol which introduces a new binding
          -- then we need to check for allowed globals
          assertCompile(not isReference or isLocal or globalAllowed(parts[1]),
                        'unknown global in strict mode: ' .. parts[1], symbol)
          if not isLocal then
              utils.root.scope.refedglobals[parts[1]] = true
          end
          return utils.expr(combineParts(parts, scope), etype)
      end
  
  
      -- Emit Lua code
      local function emit(chunk, out, ast)
          if type(out) == 'table' then
              table.insert(chunk, out)
          else
              table.insert(chunk, {leaf = out, ast = ast})
          end
      compiler.emit(parent, chunk0, ast)
      compiler.emit(parent, "end", ast)
      return (outer_retexprs or retexprs)
    end
    if (opts.target or (opts.nval == 0) or opts.tail) then
      compiler.emit(parent, "do", ast)
      return compile_body(opts.target, opts.tail)
    elseif opts.nval then
      local syms = {}
      for i = 1, opts.nval do
        local s = ((pre_syms and pre_syms[i]) or compiler.gensym(scope))
        syms[i] = s
        retexprs[i] = utils.expr(s, "sym")
      end
      local outer_target = table.concat(syms, ", ")
      compiler.emit(parent, string.format("local %s", outer_target), ast)
      compiler.emit(parent, "do", ast)
      return compile_body(outer_target, opts.tail)
    else
      local fname = compiler.gensym(scope)
      local fargs = nil
      if scope.vararg then
        fargs = "..."
      else
        fargs = ""
      end
  
      -- Do some peephole optimization.
      local function peephole(chunk)
          if chunk.leaf then return chunk end
          -- Optimize do ... end in some cases.
          if #chunk >= 3 and
              chunk[#chunk - 2].leaf == 'do' and
              not chunk[#chunk - 1].leaf and
              chunk[#chunk].leaf == 'end' then
              local kid = peephole(chunk[#chunk - 1])
              local newChunk = {ast = chunk.ast}
              for i = 1, #chunk - 3 do table.insert(newChunk, peephole(chunk[i])) end
              for i = 1, #kid do table.insert(newChunk, kid[i]) end
              return newChunk
          end
          -- Recurse
          return utils.map(chunk, peephole)
      end
  
      -- correlate line numbers in input with line numbers in output
      local function flattenChunkCorrelated(mainChunk)
          local function flatten(chunk, out, lastLine, file)
              if chunk.leaf then
                  out[lastLine] = (out[lastLine] or "") .. " " .. chunk.leaf
              else
                  for _, subchunk in ipairs(chunk) do
                      -- Ignore empty chunks
                      if subchunk.leaf or #subchunk > 0 then
                          -- don't increase line unless it's from the same file
                          if subchunk.ast and file == subchunk.ast.file then
                              lastLine = math.max(lastLine, subchunk.ast.line or 0)
                          end
                          lastLine = flatten(subchunk, out, lastLine, file)
                      end
                  end
              end
              return lastLine
          end
          local out = {}
          local last = flatten(mainChunk, out, 1, mainChunk.file)
          for i = 1, last do
              if out[i] == nil then out[i] = "" end
          end
          return table.concat(out, "\n")
      end
  
      -- Flatten a tree of indented Lua source code lines.
      -- Tab is what is used to indent a block.
      local function flattenChunk(sm, chunk, tab, depth)
          if type(tab) == 'boolean' then tab = tab and '  ' or '' end
          if chunk.leaf then
              local code = chunk.leaf
              local info = chunk.ast
              -- Just do line info for now to save memory
              if sm then sm[#sm + 1] = info and info.line or -1 end
              return code
          else
              local parts = utils.map(chunk, function(c)
                  if c.leaf or #c > 0 then -- Ignore empty chunks
                      local sub = flattenChunk(sm, c, tab, depth + 1)
                      if depth > 0 then sub = tab .. sub:gsub('\n', '\n' .. tab) end
                      return sub
                  end
              end)
              return table.concat(parts, '\n')
          end
      compiler.emit(parent, string.format("local function %s(%s)", fname, fargs), ast)
      utils.hook("do", ast, sub_scope0)
      return compile_body(nil, true, utils.expr((fname .. "(" .. fargs .. ")"), "statement"))
    end
  end
  doc_special("do", {"..."}, "Evaluate multiple forms; return last value.")
  SPECIALS.values = function(ast, scope, parent)
    local len = #ast
    local exprs = {}
    for i = 2, len do
      local subexprs = compiler.compile1(ast[i], scope, parent, {nval = ((i ~= len) and 1)})
      table.insert(exprs, subexprs[1])
      if (i == len) then
        for j = 2, #subexprs do
          table.insert(exprs, subexprs[j])
        end
      end
  
      -- Some global state for all fennel sourcemaps. For the time being,
      -- this seems the easiest way to store the source maps.
      -- Sourcemaps are stored with source being mapped as the key, prepended
      -- with '@' if it is a filename (like debug.getinfo returns for source).
      -- The value is an array of mappings for each line.
      local fennelSourcemap = {}
      -- TODO: loading, unloading, and saving sourcemaps?
  
      local function makeShortSrc(source)
          source = source:gsub('\n', ' ')
          if #source <= 49 then
              return '[fennel "' .. source .. '"]'
          else
              return '[fennel "' .. source:sub(1, 46) .. '..."]'
          end
    end
    return exprs
  end
  doc_special("values", {"..."}, "Return multiple values from a function. Must be in tail position.")
  local function set_fn_metadata(arg_list, docstring, parent, fn_name)
    if utils.root.options.useMetadata then
      local args = nil
      local function _0_(v)
        if utils["table?"](v) then
          return "\"#<table>\""
        else
          return ("\"%s\""):format(tostring(v))
        end
      end
  
      -- Return Lua source and source map table
      local function flatten(chunk, options)
          chunk = peephole(chunk)
          if(options.correlate) then
              return flattenChunkCorrelated(chunk), {}
          else
              local sm = {}
              local ret = flattenChunk(sm, chunk, options.indent, 0)
              if sm then
                  local key, short_src
                  if options.filename then
                      short_src = options.filename
                      key = '@' .. short_src
                  else
                      key = ret
                      short_src = makeShortSrc(options.source or ret)
                  end
                  sm.short_src = short_src
                  sm.key = key
                  fennelSourcemap[key] = sm
              end
              return ret, sm
          end
      args = utils.map(arg_list, _0_)
      local meta_fields = {"\"fnl/arglist\"", ("{" .. table.concat(args, ", ") .. "}")}
      if docstring then
        table.insert(meta_fields, "\"fnl/docstring\"")
        table.insert(meta_fields, ("\"" .. docstring:gsub("%s+$", ""):gsub("\\", "\\\\"):gsub("\n", "\\n"):gsub("\"", "\\\"") .. "\""))
      end
  
      -- module-wide state for metadata
      -- create metadata table with weakly-referenced keys
      local function makeMetadata()
          return setmetatable({}, {
              __mode = 'k',
              __index = {
                  get = function(self, tgt, key)
                      if self[tgt] then return self[tgt][key] end
                  end,
                  set = function(self, tgt, key, value)
                      self[tgt] = self[tgt] or {}
                      self[tgt][key] = value
                      return tgt
                  end,
                  setall = function(self, tgt, ...)
                      local kvLen, kvs = select('#', ...), {...}
                      if kvLen % 2 ~= 0 then
                          error('metadata:setall() expected even number of k/v pairs')
                      end
                      self[tgt] = self[tgt] or {}
                      for i = 1, kvLen, 2 do self[tgt][kvs[i]] = kvs[i + 1] end
                      return tgt
                  end,
              }})
      end
  
      -- Convert expressions to Lua string
      local function exprs1(exprs)
          return table.concat(utils.map(exprs, 1), ', ')
      end
  
      -- Compile side effects for a chunk
      local function keepSideEffects(exprs, chunk, start, ast)
          start = start or 1
          for j = start, #exprs do
              local se = exprs[j]
              -- Avoid the rogue 'nil' expression (nil is usually a literal,
              -- but becomes an expression if a special form
              -- returns 'nil'.)
              if se.type == 'expression' and se[1] ~= 'nil' then
                  emit(chunk, ('do local _ = %s end'):format(tostring(se)), ast)
              elseif se.type == 'statement' then
                  local code = tostring(se)
                  emit(chunk, code:byte() == 40 and ("do end " .. code) or code , ast)
              end
          end
      local meta_str = ("require(\"%s\").metadata"):format((utils.root.options.moduleName or "fennel"))
      return compiler.emit(parent, ("pcall(function() %s:setall(%s, %s) end)"):format(meta_str, fn_name, table.concat(meta_fields, ", ")))
    end
  end
  local function get_fn_name(ast, scope, fn_name, multi)
    if (fn_name and (fn_name[1] ~= "nil")) then
      local _0_
      if not multi then
        _0_ = compiler["declare-local"](fn_name, {}, scope, ast)
      else
        _0_ = compiler["symbol-to-expression"](fn_name, scope)[1]
      end
  
      -- Does some common handling of returns and register
      -- targets for special forms. Also ensures a list expression
      -- has an acceptable number of expressions if opts contains the
      -- "nval" option.
      local function handleCompileOpts(exprs, parent, opts, ast)
          if opts.nval then
              local n = opts.nval
              if n ~= #exprs then
                  local len = #exprs
                  if len > n then
                      -- Drop extra
                      keepSideEffects(exprs, parent, n + 1, ast)
                      for i = n + 1, len do
                          exprs[i] = nil
                      end
                  else
                      -- Pad with nils
                      for i = #exprs + 1, n do
                          exprs[i] = utils.expr('nil', 'literal')
                      end
                  end
              end
          end
          if opts.tail then
              emit(parent, ('return %s'):format(exprs1(exprs)), ast)
          end
          if opts.target then
              local result = exprs1(exprs)
              if result == '' then result = 'nil' end
              emit(parent, ('%s = %s'):format(opts.target, result), ast)
          end
          if opts.tail or opts.target then
              -- Prevent statements and expression from being used twice if they
              -- have side-effects. Since if the target or tail options are set,
              -- the expressions are already emitted, we should not return them. This
              -- is fine, as when these options are set, the caller doesn't need the result
              -- anyways.
              exprs = {}
          end
          return exprs
      end
  
      local function macroexpand(ast, scope, once)
          if not utils.isList(ast) then return ast end -- bail early if not a list form
          local multiSymParts = utils.isMultiSym(ast[1])
          local macro = utils.isSym(ast[1]) and scope.macros[utils.deref(ast[1])]
          if not macro and multiSymParts then
              local inMacroModule
              macro = scope.macros
              for i = 1, #multiSymParts do
                  macro = utils.isTable(macro) and macro[multiSymParts[i]]
                  if macro then inMacroModule = true end
              end
              assertCompile(not inMacroModule or type(macro) == 'function',
                  'macro not found in imported macro module', ast)
          end
          if not macro then return ast end
          local oldScope = scopes.macro
          scopes.macro = scope
          local ok, transformed = pcall(macro, unpack(ast, 2))
          scopes.macro = oldScope
          assertCompile(ok, transformed, ast)
          if once or not transformed then return transformed end -- macroexpand-1
          return macroexpand(transformed, scope)
      end
  
      -- Compile an AST expression in the scope into parent, a tree
      -- of lines that is eventually compiled into Lua code. Also
      -- returns some information about the evaluation of the compiled expression,
      -- which can be used by the calling function. Macros
      -- are resolved here, as well as special forms in that order.
      -- the 'ast' param is the root AST to compile
      -- the 'scope' param is the scope in which we are compiling
      -- the 'parent' param is the table of lines that we are compiling into.
      -- add lines to parent by appending strings. Add indented blocks by appending
      -- tables of more lines.
      -- the 'opts' param contains info about where the form is being compiled.
      -- Options include:
      --   'target' - mangled name of symbol(s) being compiled to.
      --      Could be one variable, 'a', or a list, like 'a, b, _0_'.
      --   'tail' - boolean indicating tail position if set. If set, form will generate a return
      --   instruction.
      --   'nval' - The number of values to compile to if it is known to be a fixed value.
  
      -- In Lua, an expression can evaluate to 0 or more values via multiple
      -- returns. In many cases, Lua will drop extra values and convert a 0 value
      -- expression to nil. In other cases, Lua will use all of the values in an
      -- expression, such as in the last argument of a function call. Nval is an
      -- option passed to compile1 to say that the resulting expression should have
      -- at least n values. It lets us generate better code, because if we know we
      -- are only going to use 1 or 2 values from an expression, we can create 1 or 2
      -- locals to store intermediate results rather than turn the expression into a
      -- closure that is called immediately, which we have to do if we don't know.
  
      local function compile1(ast, scope, parent, opts)
          opts = opts or {}
          local exprs = {}
          -- expand any top-level macros before parsing and emitting Lua
          ast = macroexpand(ast, scope)
          -- Compile the form
          if utils.isList(ast) then -- Function call or special form
              assertCompile(#ast > 0, "expected a function, macro, or special to call", ast)
              -- Test for special form
              local len, first = #ast, ast[1]
              local multiSymParts = utils.isMultiSym(first)
              local special = utils.isSym(first) and scope.specials[utils.deref(first)]
              if special then -- Special form
                  exprs = special(ast, scope, parent, opts) or utils.expr('nil', 'literal')
                  -- Be very accepting of strings or expression
                  -- as well as lists or expressions
                  if type(exprs) == 'string' then exprs = utils.expr(exprs, 'expression') end
                  if utils.isExpr(exprs) then exprs = {exprs} end
                  -- Unless the special form explicitly handles the target, tail, and
                  -- nval properties, (indicated via the 'returned' flag), handle
                  -- these options.
                  if not exprs.returned then
                      exprs = handleCompileOpts(exprs, parent, opts, ast)
                  elseif opts.tail or opts.target then
                      exprs = {}
                  end
                  exprs.returned = true
                  return exprs
              elseif multiSymParts and multiSymParts.multiSymMethodCall then
                  local tableWithMethod = table.concat({
                          unpack(multiSymParts, 1, #multiSymParts - 1)
                                                       }, '.')
                  local methodToCall = multiSymParts[#multiSymParts]
                  local newAST = utils.list(utils.sym(':', scope), utils.sym(tableWithMethod, scope),
                                            methodToCall)
                  for i = 2, len do
                      newAST[#newAST + 1] = ast[i]
                  end
                  local compiled = compile1(newAST, scope, parent, opts)
                  exprs = compiled
              else -- Function call
                  local fargs = {}
                  local fcallee = compile1(ast[1], scope, parent, {
                      nval = 1
                  })[1]
                  assertCompile(fcallee.type ~= 'literal',
                                'cannot call literal value', ast)
                  fcallee = tostring(fcallee)
                  for i = 2, len do
                      local subexprs = compile1(ast[i], scope, parent, {
                          nval = i ~= len and 1 or nil
                      })
                      fargs[#fargs + 1] = subexprs[1] or utils.expr('nil', 'literal')
                      if i == len then
                          -- Add sub expressions to function args
                          for j = 2, #subexprs do
                              fargs[#fargs + 1] = subexprs[j]
                          end
                      else
                          -- Emit sub expression only for side effects
                          keepSideEffects(subexprs, parent, 2, ast[i])
                      end
                  end
                  local call = ('%s(%s)'):format(tostring(fcallee), exprs1(fargs))
                  exprs = handleCompileOpts({utils.expr(call, 'statement')}, parent, opts, ast)
              end
          elseif utils.isVarg(ast) then
              assertCompile(scope.vararg, "unexpected vararg", ast)
              exprs = handleCompileOpts({utils.expr('...', 'varg')}, parent, opts, ast)
          elseif utils.isSym(ast) then
              local e
              local multiSymParts = utils.isMultiSym(ast)
              assertCompile(not (multiSymParts and multiSymParts.multiSymMethodCall),
                            "multisym method calls may only be in call position", ast)
              -- Handle nil as special symbol - it resolves to the nil literal rather than
              -- being unmangled. Alternatively, we could remove it from the lua keywords table.
              if ast[1] == 'nil' then
                  e = utils.expr('nil', 'literal')
              else
                  e = symbolToExpression(ast, scope, true)
              end
              exprs = handleCompileOpts({e}, parent, opts, ast)
          elseif type(ast) == 'nil' or type(ast) == 'boolean' then
              exprs = handleCompileOpts({utils.expr(tostring(ast), 'literal')}, parent, opts)
          elseif type(ast) == 'number' then
              local n = ('%.17g'):format(ast)
              exprs = handleCompileOpts({utils.expr(n, 'literal')}, parent, opts)
          elseif type(ast) == 'string' then
              local s = serializeString(ast)
              exprs = handleCompileOpts({utils.expr(s, 'literal')}, parent, opts)
          elseif type(ast) == 'table' then
              local buffer = {}
              for i = 1, #ast do -- Write numeric keyed values.
                  local nval = i ~= #ast and 1
                  buffer[#buffer + 1] = exprs1(compile1(ast[i], scope,
                                                        parent, {nval = nval}))
              end
              local function writeOtherValues(k)
                  if type(k) ~= 'number' or math.floor(k) ~= k or k < 1 or k > #ast then
                      if type(k) == 'string' and utils.isValidLuaIdentifier(k) then
                          return {k, k}
                      else
                          local kstr = '[' .. tostring(compile1(k, scope, parent,
                                                                {nval = 1})[1]) .. ']'
                          return { kstr, k }
                      end
                  end
              end
              local keys = utils.kvmap(ast, writeOtherValues)
              table.sort(keys, function (a, b) return a[1] < b[1] end)
              utils.map(keys, function(k)
                      local v = tostring(compile1(ast[k[2]], scope, parent, {nval = 1})[1])
                      return ('%s = %s'):format(k[1], v) end,
                  buffer)
              local tbl = '{' .. table.concat(buffer, ', ') ..'}'
              exprs = handleCompileOpts({utils.expr(tbl, 'expression')}, parent, opts, ast)
          else
              assertCompile(false, 'could not compile value of type ' .. type(ast), ast)
          end
          exprs.returned = true
          return exprs
      end
  
      -- Implements destructuring for forms like let, bindings, etc.
      -- Takes a number of options to control behavior.
      -- var: Whether or not to mark symbols as mutable
      -- declaration: begin each assignment with 'local' in output
      -- nomulti: disallow multisyms in the destructuring. Used for (local) and (global).
      -- noundef: Don't set undefined bindings. (set)
      -- forceglobal: Don't allow local bindings
      local function destructure(to, from, ast, scope, parent, opts)
          opts = opts or {}
          local isvar = opts.isvar
          local declaration = opts.declaration
          local nomulti = opts.nomulti
          local noundef = opts.noundef
          local forceglobal = opts.forceglobal
          local forceset = opts.forceset
          local setter = declaration and "local %s = %s" or "%s = %s"
  
          local newManglings = {}
  
          -- Get Lua source for symbol, and check for errors
          local function getname(symbol, up1)
              local raw = symbol[1]
              assertCompile(not (nomulti and utils.isMultiSym(raw)),
                  'unexpected multi symbol ' .. raw, up1)
              if declaration then
                  return declareLocal(symbol, {var = isvar}, scope,
                                      symbol, newManglings)
              else
                  local parts = utils.isMultiSym(raw) or {raw}
                  local meta = scope.symmeta[parts[1]]
                  if #parts == 1 and not forceset then
                      assertCompile(not(forceglobal and meta),
                          ("global %s conflicts with local"):format(tostring(symbol)), symbol)
                      assertCompile(not (meta and not meta.var),
                          'expected var ' .. raw, symbol)
                      assertCompile(meta or not noundef,
                          'expected local ' .. parts[1], symbol)
                  end
                  if forceglobal then
                      assertCompile(not scope.symmeta[scope.unmanglings[raw]],
                                    "global " .. raw .. " conflicts with local", symbol)
                      scope.manglings[raw] = globalMangling(raw)
                      scope.unmanglings[globalMangling(raw)] = raw
                      if allowedGlobals then
                          table.insert(allowedGlobals, raw)
                      end
                  end
  
                  return symbolToExpression(symbol, scope)[1]
              end
          end
  
          -- Compile the outer most form. We can generate better Lua in this case.
          local function compileTopTarget(lvalues)
              -- Calculate initial rvalue
              local inits = utils.map(lvalues, function(x)
                                    return scope.manglings[x] and x or 'nil' end)
              local init = table.concat(inits, ', ')
              local lvalue = table.concat(lvalues, ', ')
  
              local plen, plast = #parent, parent[#parent]
              local ret = compile1(from, scope, parent, {target = lvalue})
              if declaration then
                  -- A single leaf emitted at the end of the parent chunk means
                  -- a simple assignment a = x was emitted, and we can just
                  -- splice "local " onto the front of it. However, we can't
                  -- just check based on plen, because some forms (such as
                  -- include) insert new chunks at the top of the parent chunk
                  -- rather than just at the end; this loop checks for this
                  -- occurance and updates plen to be the index of the last
                  -- thing in the parent before compiling the new value.
                  for pi = plen, #parent do
                      if parent[pi] == plast then plen = pi end
                  end
                  if #parent == plen + 1 and parent[#parent].leaf then
                      parent[#parent].leaf = 'local ' .. parent[#parent].leaf
                  else
                      table.insert(parent, plen + 1,
                                   { leaf = 'local ' .. lvalue .. ' = ' .. init,
                                     ast = ast})
                  end
              end
              return ret
          end
  
          -- Recursive auxiliary function
          local function destructure1(left, rightexprs, up1, top)
              if utils.isSym(left) and left[1] ~= "nil" then
                  checkBindingValid(left, scope, left)
                  local lname = getname(left, up1)
                  if top then
                      compileTopTarget({lname})
                  else
                      emit(parent, setter:format(lname, exprs1(rightexprs)), left)
                  end
              elseif utils.isTable(left) then -- table destructuring
                  if top then rightexprs = compile1(from, scope, parent) end
                  local s = gensym(scope)
                  local right = exprs1(rightexprs)
                  if right == '' then right = 'nil' end
                  emit(parent, ("local %s = %s"):format(s, right), left)
                  for k, v in utils.stablepairs(left) do
                      if utils.isSym(left[k]) and left[k][1] == "&" then
                          assertCompile(type(k) == "number" and not left[k+2],
                              "expected rest argument before last parameter", left)
                          local subexpr = utils.expr(('{(table.unpack or unpack)(%s, %s)}')
                                  :format(s, k), 'expression')
                          destructure1(left[k+1], {subexpr}, left)
                          return
                      else
                          if utils.isSym(k) and tostring(k) == ":" and utils.isSym(v) then
                              k = tostring(v)
                          end
                          if type(k) ~= "number" then k = serializeString(k) end
                          local subexpr = utils.expr(('%s[%s]'):format(s, k), 'expression')
                          destructure1(v, {subexpr}, left)
                      end
                  end
              elseif utils.isList(left) then -- values destructuring
                  local leftNames, tables = {}, {}
                  for i, name in ipairs(left) do
                      local symname
                      if utils.isSym(name) then -- binding directly to a name
                          symname = getname(name, up1)
                      else -- further destructuring of tables inside values
                          symname = gensym(scope)
                          tables[i] = {name, utils.expr(symname, 'sym')}
                      end
                      table.insert(leftNames, symname)
                  end
                  if top then
                      compileTopTarget(leftNames)
                  else
                      local lvalue = table.concat(leftNames, ', ')
                      emit(parent, setter:format(lvalue, exprs1(rightexprs)), left)
                  end
                  for _, pair in utils.stablepairs(tables) do -- recurse if left-side tables found
                      destructure1(pair[1], {pair[2]}, left)
                  end
              else
                  assertCompile(false, ("unable to bind %s %s"):
                                    format(type(left), tostring(left)),
                                type(up1[2]) == "table" and up1[2] or up1)
              end
              if top then return {returned = true} end
          end
  
          local ret = destructure1(to, nil, ast, true)
          applyManglings(scope, newManglings, ast)
          return ret
      end
  
      local function requireInclude(ast, scope, parent, opts)
          opts.fallback = function(e)
              return utils.expr(('require(%s)'):format(tostring(e)), 'statement')
      return _0_, not multi, 3
    else
      return compiler.gensym(scope), true, 2
    end
  end
  SPECIALS.fn = function(ast, scope, parent)
    local f_scope = nil
    do
      local _0_0 = compiler["make-scope"](scope)
      _0_0["vararg"] = false
      f_scope = _0_0
    end
    local f_chunk = {}
    local fn_sym = utils["sym?"](ast[2])
    local multi = (fn_sym and utils["multi-sym?"](fn_sym[1]))
    local fn_name, local_fn_3f, index = get_fn_name(ast, scope, fn_sym, multi)
    local arg_list = compiler.assert(utils["table?"](ast[index]), "expected parameters table", ast)
    compiler.assert((not multi or not multi["multi-sym-method-call"]), ("unexpected multi symbol " .. tostring(fn_name)), fn_sym)
    local function get_arg_name(arg)
      if utils["varg?"](arg) then
        compiler.assert((arg == arg_list[#arg_list]), "expected vararg as last parameter", ast)
        f_scope.vararg = true
        return "..."
      elseif (utils["sym?"](arg) and (utils.deref(arg) ~= "nil") and not utils["multi-sym?"](utils.deref(arg))) then
        return compiler["declare-local"](arg, {}, f_scope, ast)
      elseif utils["table?"](arg) then
        local raw = utils.sym(compiler.gensym(scope))
        local declared = compiler["declare-local"](raw, {}, f_scope, ast)
        compiler.destructure(arg, raw, ast, f_scope, f_chunk, {declaration = true, nomulti = true})
        return declared
      else
        return compiler.assert(false, ("expected symbol for function parameter: %s"):format(tostring(arg)), ast[2])
      end
    end
    do
      local arg_name_list = utils.map(arg_list, get_arg_name)
      local index0, docstring = nil, nil
      if ((type(ast[(index + 1)]) == "string") and ((index + 1) < #ast)) then
        index0, docstring = (index + 1), ast[(index + 1)]
      else
        index0, docstring = index, nil
      end
      for i = (index0 + 1), #ast do
        compiler.compile1(ast[i], f_scope, f_chunk, {nval = (((i ~= #ast) and 0) or nil), tail = (i == #ast)})
      end
      local _2_
      if local_fn_3f then
        _2_ = "local function %s(%s)"
      else
        _2_ = "%s = function(%s)"
      end
      compiler.emit(parent, string.format(_2_, fn_name, table.concat(arg_name_list, ", ")), ast)
      compiler.emit(parent, f_chunk, ast)
      compiler.emit(parent, "end", ast)
      set_fn_metadata(arg_list, docstring, parent, fn_name)
    end
    utils.hook("fn", ast, f_scope)
    return utils.expr(fn_name, "sym")
  end
  doc_special("fn", {"name?", "args", "docstring?", "..."}, "Function syntax. May optionally include a name and docstring.\nIf a name is provided, the function will be bound in the current scope.\nWhen called with the wrong number of args, excess args will be discarded\nand lacking args will be nil, use lambda for arity-checked functions.")
  SPECIALS.lua = function(ast, _, parent)
    compiler.assert(((#ast == 2) or (#ast == 3)), "expected 1 or 2 arguments", ast)
    if (ast[2] ~= nil) then
      table.insert(parent, {ast = ast, leaf = tostring(ast[2])})
    end
    if (#ast == 3) then
      return tostring(ast[3])
    end
  end
  SPECIALS.doc = function(ast, scope, parent)
    assert(utils.root.options.useMetadata, "can't look up doc with metadata disabled.")
    compiler.assert((#ast == 2), "expected one argument", ast)
    local target = utils.deref(ast[2])
    local special_or_macro = (scope.specials[target] or scope.macros[target])
    if special_or_macro then
      return ("print(%q)"):format(doc_2a(special_or_macro, target))
    else
      local value = tostring(compiler.compile1(ast[2], scope, parent, {nval = 1})[1])
      return ("print(require('%s').doc(%s, '%s'))"):format((utils.root.options.moduleName or "fennel"), value, tostring(ast[2]))
    end
  end
  doc_special("doc", {"x"}, "Print the docstring and arglist for a function, macro, or special form.")
  local function dot(ast, scope, parent)
    compiler.assert((1 < #ast), "expected table argument", ast)
    local len = #ast
    local _0_ = compiler.compile1(ast[2], scope, parent, {nval = 1})
    local lhs = _0_[1]
    if (len == 2) then
      return tostring(lhs)
    else
      local indices = {}
      for i = 3, len do
        local index = ast[i]
        if ((type(index) == "string") and utils["valid-lua-identifier?"](index)) then
          table.insert(indices, ("." .. index))
        else
          local _1_ = compiler.compile1(index, scope, parent, {nval = 1})
          local index0 = _1_[1]
          table.insert(indices, ("[" .. tostring(index0) .. "]"))
        end
      end
      if (tostring(lhs):find("{") or ("nil" == tostring(lhs))) then
        return ("(" .. tostring(lhs) .. ")" .. table.concat(indices))
      else
        return (tostring(lhs) .. table.concat(indices))
      end
    end
  end
  SPECIALS["."] = dot
  doc_special(".", {"tbl", "key1", "..."}, "Look up key1 in tbl table. If more args are provided, do a nested lookup.")
  SPECIALS.global = function(ast, scope, parent)
    compiler.assert((#ast == 3), "expected name and value", ast)
    compiler.destructure(ast[2], ast[3], ast, scope, parent, {forceglobal = true, nomulti = true})
    return nil
  end
  doc_special("global", {"name", "val"}, "Set name as a global with val.")
  SPECIALS.set = function(ast, scope, parent)
    compiler.assert((#ast == 3), "expected name and value", ast)
    compiler.destructure(ast[2], ast[3], ast, scope, parent, {noundef = true})
    return nil
  end
  doc_special("set", {"name", "val"}, "Set a local variable to a new value. Only works on locals using var.")
  local function set_forcibly_21_2a(ast, scope, parent)
    compiler.assert((#ast == 3), "expected name and value", ast)
    compiler.destructure(ast[2], ast[3], ast, scope, parent, {forceset = true})
    return nil
  end
  SPECIALS["set-forcibly!"] = set_forcibly_21_2a
  local function local_2a(ast, scope, parent)
    compiler.assert((#ast == 3), "expected name and value", ast)
    compiler.destructure(ast[2], ast[3], ast, scope, parent, {declaration = true, nomulti = true})
    return nil
  end
  SPECIALS["local"] = local_2a
  doc_special("local", {"name", "val"}, "Introduce new top-level immutable local.")
  SPECIALS.var = function(ast, scope, parent)
    compiler.assert((#ast == 3), "expected name and value", ast)
    compiler.destructure(ast[2], ast[3], ast, scope, parent, {declaration = true, isvar = true, nomulti = true})
    return nil
  end
  doc_special("var", {"name", "val"}, "Introduce new mutable local.")
  SPECIALS.let = function(ast, scope, parent, opts)
    local bindings = ast[2]
    local pre_syms = {}
    compiler.assert((utils["list?"](bindings) or utils["table?"](bindings)), "expected binding table", ast)
    compiler.assert(((#bindings % 2) == 0), "expected even number of name/value bindings", ast[2])
    compiler.assert((#ast >= 3), "expected body expression", ast[1])
    for _ = 1, (opts.nval or 0) do
      table.insert(pre_syms, compiler.gensym(scope))
    end
    local sub_scope = compiler["make-scope"](scope)
    local sub_chunk = {}
    for i = 1, #bindings, 2 do
      compiler.destructure(bindings[i], bindings[(i + 1)], ast, sub_scope, sub_chunk, {declaration = true, nomulti = true})
    end
    return SPECIALS["do"](ast, scope, parent, opts, 3, sub_chunk, sub_scope, pre_syms)
  end
  doc_special("let", {"[name1 val1 ... nameN valN]", "..."}, "Introduces a new scope in which a given set of local bindings are used.")
  SPECIALS.tset = function(ast, scope, parent)
    compiler.assert((#ast > 3), "expected table, key, and value arguments", ast)
    local root = compiler.compile1(ast[2], scope, parent, {nval = 1})[1]
    local keys = {}
    for i = 3, (#ast - 1) do
      local _0_ = compiler.compile1(ast[i], scope, parent, {nval = 1})
      local key = _0_[1]
      table.insert(keys, tostring(key))
    end
    local value = compiler.compile1(ast[#ast], scope, parent, {nval = 1})[1]
    local rootstr = tostring(root)
    local fmtstr = nil
    if rootstr:match("^{") then
      fmtstr = "do end (%s)[%s] = %s"
    else
      fmtstr = "%s[%s] = %s"
    end
    return compiler.emit(parent, fmtstr:format(tostring(root), table.concat(keys, "]["), tostring(value)), ast)
  end
  doc_special("tset", {"tbl", "key1", "...", "keyN", "val"}, "Set the value of a table field. Can take additional keys to set\nnested values, but all parents must contain an existing table.")
  local function calculate_target(scope, opts)
    if not (opts.tail or opts.target or opts.nval) then
      return "iife", true, nil
    elseif (opts.nval and (opts.nval ~= 0) and not opts.target) then
      local accum = {}
      local target_exprs = {}
      for i = 1, opts.nval do
        local s = compiler.gensym(scope)
        accum[i] = s
        target_exprs[i] = utils.expr(s, "sym")
      end
      return "target", opts.tail, table.concat(accum, ", "), target_exprs
    else
      return "none", opts.tail, opts.target
    end
  end
  local function if_2a(ast, scope, parent, opts)
    local do_scope = compiler["make-scope"](scope)
    local branches = {}
    local wrapper, inner_tail, inner_target, target_exprs = calculate_target(scope, opts)
    local body_opts = {nval = opts.nval, tail = inner_tail, target = inner_target}
    local function compile_body(i)
      local chunk = {}
      local cscope = compiler["make-scope"](do_scope)
      compiler["keep-side-effects"](compiler.compile1(ast[i], cscope, chunk, body_opts), chunk, nil, ast[i])
      return {chunk = chunk, scope = cscope}
    end
    for i = 2, (#ast - 1), 2 do
      local condchunk = {}
      local res = compiler.compile1(ast[i], do_scope, condchunk, {nval = 1})
      local cond = res[1]
      local branch = compile_body((i + 1))
      branch.cond = cond
      branch.condchunk = condchunk
      branch.nested = ((i ~= 2) and (next(condchunk, nil) == nil))
      table.insert(branches, branch)
    end
    local has_else_3f = ((#ast > 3) and ((#ast % 2) == 0))
    local else_branch = (has_else_3f and compile_body(#ast))
    local s = compiler.gensym(scope)
    local buffer = {}
    local last_buffer = buffer
    for i = 1, #branches do
      local branch = branches[i]
      local fstr = nil
      if not branch.nested then
        fstr = "if %s then"
      else
        fstr = "elseif %s then"
      end
      local cond = tostring(branch.cond)
      local cond_line = nil
      if ((cond == "true") and branch.nested and (i == #branches)) then
        cond_line = "else"
      else
        cond_line = fstr:format(cond)
      end
      if branch.nested then
        compiler.emit(last_buffer, branch.condchunk, ast)
      else
        for _, v in ipairs(branch.condchunk) do
          compiler.emit(last_buffer, v, ast)
        end
      end
      compiler.emit(last_buffer, cond_line, ast)
      compiler.emit(last_buffer, branch.chunk, ast)
      if (i == #branches) then
        if has_else_3f then
          compiler.emit(last_buffer, "else", ast)
          compiler.emit(last_buffer, else_branch.chunk, ast)
        elseif (inner_target and (cond_line ~= "else")) then
          compiler.emit(last_buffer, "else", ast)
          compiler.emit(last_buffer, ("%s = nil"):format(inner_target), ast)
        end
        compiler.emit(last_buffer, "end", ast)
      elseif not branches[(i + 1)].nested then
        local next_buffer = {}
        compiler.emit(last_buffer, "else", ast)
        compiler.emit(last_buffer, next_buffer, ast)
        compiler.emit(last_buffer, "end", ast)
        last_buffer = next_buffer
      end
    end
    if (wrapper == "iife") then
      local iifeargs = ((scope.vararg and "...") or "")
      compiler.emit(parent, ("local function %s(%s)"):format(tostring(s), iifeargs), ast)
      compiler.emit(parent, buffer, ast)
      compiler.emit(parent, "end", ast)
      return utils.expr(("%s(%s)"):format(tostring(s), iifeargs), "statement")
    elseif (wrapper == "none") then
      for i = 1, #buffer do
        compiler.emit(parent, buffer[i], ast)
      end
      return {returned = true}
    else
      compiler.emit(parent, ("local %s"):format(inner_target), ast)
      for i = 1, #buffer do
        compiler.emit(parent, buffer[i], ast)
      end
      return target_exprs
    end
  end
  SPECIALS["if"] = if_2a
  doc_special("if", {"cond1", "body1", "...", "condN", "bodyN"}, "Conditional form.\nTakes any number of condition/body pairs and evaluates the first body where\nthe condition evaluates to truthy. Similar to cond in other lisps.")
  SPECIALS.each = function(ast, scope, parent)
    compiler.assert((#ast >= 3), "expected body expression", ast[1])
    local binding = compiler.assert(utils["table?"](ast[2]), "expected binding table", ast)
    local iter = table.remove(binding, #binding)
    local destructures = {}
    local new_manglings = {}
    local sub_scope = compiler["make-scope"](scope)
    local function destructure_binding(v)
      if utils["sym?"](v) then
        return compiler["declare-local"](v, {}, sub_scope, ast, new_manglings)
      else
        local raw = utils.sym(compiler.gensym(sub_scope))
        destructures[raw] = v
        return compiler["declare-local"](raw, {}, sub_scope, ast)
      end
    end
    local bind_vars = utils.map(binding, destructure_binding)
    local vals = compiler.compile1(iter, sub_scope, parent)
    local val_names = utils.map(vals, tostring)
    local chunk = {}
    compiler.emit(parent, ("for %s in %s do"):format(table.concat(bind_vars, ", "), table.concat(val_names, ", ")), ast)
    for raw, args in utils.stablepairs(destructures) do
      compiler.destructure(args, raw, ast, sub_scope, chunk, {declaration = true, nomulti = true})
    end
    compiler["apply-manglings"](sub_scope, new_manglings, ast)
    compile_do(ast, sub_scope, chunk, 3)
    compiler.emit(parent, chunk, ast)
    return compiler.emit(parent, "end", ast)
  end
  doc_special("each", {"[key value (iterator)]", "..."}, "Runs the body once for each set of values provided by the given iterator.\nMost commonly used with ipairs for sequential tables or pairs for  undefined\norder, but can be used with any iterator.")
  local function while_2a(ast, scope, parent)
    local len1 = #parent
    local condition = compiler.compile1(ast[2], scope, parent, {nval = 1})[1]
    local len2 = #parent
    local sub_chunk = {}
    if (len1 ~= len2) then
      for i = (len1 + 1), len2 do
        table.insert(sub_chunk, parent[i])
        parent[i] = nil
      end
      compiler.emit(parent, "while true do", ast)
      compiler.emit(sub_chunk, ("if not %s then break end"):format(condition[1]), ast)
    else
      compiler.emit(parent, ("while " .. tostring(condition) .. " do"), ast)
    end
    compile_do(ast, compiler["make-scope"](scope), sub_chunk, 3)
    compiler.emit(parent, sub_chunk, ast)
    return compiler.emit(parent, "end", ast)
  end
  SPECIALS["while"] = while_2a
  doc_special("while", {"condition", "..."}, "The classic while loop. Evaluates body until a condition is non-truthy.")
  local function for_2a(ast, scope, parent)
    local ranges = compiler.assert(utils["table?"](ast[2]), "expected binding table", ast)
    local binding_sym = table.remove(ast[2], 1)
    local sub_scope = compiler["make-scope"](scope)
    local range_args = {}
    local chunk = {}
    compiler.assert(utils["sym?"](binding_sym), ("unable to bind %s %s"):format(type(binding_sym), tostring(binding_sym)), ast[2])
    compiler.assert((#ast >= 3), "expected body expression", ast[1])
    for i = 1, math.min(#ranges, 3) do
      range_args[i] = tostring(compiler.compile1(ranges[i], sub_scope, parent, {nval = 1})[1])
    end
    compiler.emit(parent, ("for %s = %s do"):format(compiler["declare-local"](binding_sym, {}, sub_scope, ast), table.concat(range_args, ", ")), ast)
    compile_do(ast, sub_scope, chunk, 3)
    compiler.emit(parent, chunk, ast)
    return compiler.emit(parent, "end", ast)
  end
  SPECIALS["for"] = for_2a
  doc_special("for", {"[index start stop step?]", "..."}, "Numeric loop construct.\nEvaluates body once for each value between start and stop (inclusive).")
  local function native_method_call(ast, _scope, _parent, target, args)
    local _0_ = ast
    local _ = _0_[1]
    local _0 = _0_[2]
    local method_string = _0_[3]
    local call_string = nil
    if ((target.type == "literal") or (target.type == "expression")) then
      call_string = "(%s):%s(%s)"
    else
      call_string = "%s:%s(%s)"
    end
    return utils.expr(string.format(call_string, tostring(target), method_string, table.concat(args, ", ")), "statement")
  end
  local function nonnative_method_call(ast, scope, parent, target, args)
    local method_string = tostring(compiler.compile1(ast[3], scope, parent, {nval = 1})[1])
    local args0 = {tostring(target), unpack(args)}
    return utils.expr(string.format("%s[%s](%s)", tostring(target), method_string, table.concat(args0, ", ")), "statement")
  end
  local function double_eval_protected_method_call(ast, scope, parent, target, args)
    local method_string = tostring(compiler.compile1(ast[3], scope, parent, {nval = 1})[1])
    local call = "(function(tgt, m, ...) return tgt[m](tgt, ...) end)(%s, %s)"
    table.insert(args, 1, method_string)
    return utils.expr(string.format(call, tostring(target), table.concat(args, ", ")), "statement")
  end
  local function method_call(ast, scope, parent)
    compiler.assert((2 < #ast), "expected at least 2 arguments", ast)
    local _0_ = compiler.compile1(ast[2], scope, parent, {nval = 1})
    local target = _0_[1]
    local args = {}
    for i = 4, #ast do
      local subexprs = nil
      local _1_
      if (i ~= #ast) then
        _1_ = 1
      else
      _1_ = nil
      end
      subexprs = compiler.compile1(ast[i], scope, parent, {nval = _1_})
      utils.map(subexprs, tostring, args)
    end
    if ((type(ast[3]) == "string") and utils["valid-lua-identifier?"](ast[3])) then
      return native_method_call(ast, scope, parent, target, args)
    elseif (target.type == "sym") then
      return nonnative_method_call(ast, scope, parent, target, args)
    else
      return double_eval_protected_method_call(ast, scope, parent, target, args)
    end
  end
  SPECIALS[":"] = method_call
  doc_special(":", {"tbl", "method-name", "..."}, "Call the named method on tbl with the provided args.\nMethod name doesn't have to be known at compile-time; if it is, use\n(tbl:method-name ...) instead.")
  SPECIALS.comment = function(ast, _, parent)
    local els = {}
    for i = 2, #ast do
      local function _1_()
        local _0_0 = tostring(ast[i]):gsub("\n", " ")
        return _0_0
      end
      table.insert(els, _1_())
    end
    return compiler.emit(parent, ("-- " .. table.concat(els, " ")), ast)
  end
  doc_special("comment", {"..."}, "Comment which will be emitted in Lua output.")
  local function hashfn_max_used(f_scope, i, max)
    local max0 = nil
    if f_scope.symmeta[("$" .. i)].used then
      max0 = i
    else
      max0 = max
    end
    if (i < 9) then
      return hashfn_max_used(f_scope, (i + 1), max0)
    else
      return max0
    end
  end
  SPECIALS.hashfn = function(ast, scope, parent)
    compiler.assert((#ast == 2), "expected one argument", ast)
    local f_scope = nil
    do
      local _0_0 = compiler["make-scope"](scope)
      _0_0["vararg"] = false
      _0_0["hashfn"] = true
      f_scope = _0_0
    end
    local f_chunk = {}
    local name = compiler.gensym(scope)
    local symbol = utils.sym(name)
    local args = {}
    compiler["declare-local"](symbol, {}, scope, ast)
    for i = 1, 9 do
      args[i] = compiler["declare-local"](utils.sym(("$" .. i)), {}, f_scope, ast)
    end
    local function walker(idx, node, parent_node)
      if (utils["sym?"](node) and (utils.deref(node) == "$...")) then
        parent_node[idx] = utils.varg()
        f_scope.vararg = true
        return nil
      else
        return (utils["list?"](node) or utils["table?"](node))
      end
    end
    utils["walk-tree"](ast[2], walker)
    compiler.compile1(ast[2], f_scope, f_chunk, {tail = true})
    local max_used = hashfn_max_used(f_scope, 1, 0)
    if f_scope.vararg then
      compiler.assert((max_used == 0), "$ and $... in hashfn are mutually exclusive", ast)
    end
    local arg_str = nil
    if f_scope.vararg then
      arg_str = utils.deref(utils.varg())
    else
      arg_str = table.concat(args, ", ", 1, max_used)
    end
    compiler.emit(parent, string.format("local function %s(%s)", name, arg_str), ast)
    compiler.emit(parent, f_chunk, ast)
    compiler.emit(parent, "end", ast)
    return utils.expr(name, "sym")
  end
  doc_special("hashfn", {"..."}, "Function literal shorthand; args are either $... OR $1, $2, etc.")
  local function define_arithmetic_special(name, zero_arity, unary_prefix, lua_name)
    do
      local padded_op = (" " .. (lua_name or name) .. " ")
      local function _0_(ast, scope, parent)
        local len = #ast
        if (len == 1) then
          compiler.assert((zero_arity ~= nil), "Expected more than 0 arguments", ast)
          return utils.expr(zero_arity, "literal")
        else
          local operands = {}
          for i = 2, len do
            local subexprs = nil
            local _1_
            if (i ~= len) then
              _1_ = 1
            else
            _1_ = nil
            end
            subexprs = compiler.compile1(ast[i], scope, parent, {nval = _1_})
            utils.map(subexprs, tostring, operands)
          end
          if (#operands == 1) then
            if unary_prefix then
              return ("(" .. unary_prefix .. padded_op .. operands[1] .. ")")
            else
              return operands[1]
            end
          else
            return ("(" .. table.concat(operands, padded_op) .. ")")
          end
        end
      end
      SPECIALS[name] = _0_
    end
    return doc_special(name, {"a", "b", "..."}, "Arithmetic operator; works the same as Lua but accepts more arguments.")
  end
  define_arithmetic_special("+", "0")
  define_arithmetic_special("..", "''")
  define_arithmetic_special("^")
  define_arithmetic_special("-", nil, "")
  define_arithmetic_special("*", "1")
  define_arithmetic_special("%")
  define_arithmetic_special("/", nil, "1")
  define_arithmetic_special("//", nil, "1")
  define_arithmetic_special("lshift", nil, "1", "<<")
  define_arithmetic_special("rshift", nil, "1", ">>")
  define_arithmetic_special("band", "0", "0", "&")
  define_arithmetic_special("bor", "0", "0", "|")
  define_arithmetic_special("bxor", "0", "0", "~")
  doc_special("lshift", {"x", "n"}, "Bitwise logical left shift of x by n bits; only works in Lua 5.3+.")
  doc_special("rshift", {"x", "n"}, "Bitwise logical right shift of x by n bits; only works in Lua 5.3+.")
  doc_special("band", {"x1", "x2"}, "Bitwise AND of arguments; only works in Lua 5.3+.")
  doc_special("bor", {"x1", "x2"}, "Bitwise OR of arguments; only works in Lua 5.3+.")
  doc_special("bxor", {"x1", "x2"}, "Bitwise XOR of arguments; only works in Lua 5.3+.")
  define_arithmetic_special("or", "false")
  define_arithmetic_special("and", "true")
  doc_special("and", {"a", "b", "..."}, "Boolean operator; works the same as Lua but accepts more arguments.")
  doc_special("or", {"a", "b", "..."}, "Boolean operator; works the same as Lua but accepts more arguments.")
  doc_special("..", {"a", "b", "..."}, "String concatenation operator; works the same as Lua but accepts more arguments.")
  local function native_comparator(op, _0_0, scope, parent)
    local _1_ = _0_0
    local _ = _1_[1]
    local lhs_ast = _1_[2]
    local rhs_ast = _1_[3]
    local _2_ = compiler.compile1(lhs_ast, scope, parent, {nval = 1})
    local lhs = _2_[1]
    local _3_ = compiler.compile1(rhs_ast, scope, parent, {nval = 1})
    local rhs = _3_[1]
    return string.format("(%s %s %s)", tostring(lhs), op, tostring(rhs))
  end
  local function double_eval_protected_comparator(op, chain_op, ast, scope, parent)
    local arglist = {}
    local comparisons = {}
    local vals = {}
    local chain = string.format(" %s ", (chain_op or "and"))
    for i = 2, #ast do
      table.insert(arglist, tostring(compiler.gensym(scope)))
      table.insert(vals, tostring(compiler.compile1(ast[i], scope, parent, {nval = 1})[1]))
    end
    for i = 1, (#arglist - 1) do
      table.insert(comparisons, string.format("(%s %s %s)", arglist[i], op, arglist[(i + 1)]))
    end
    return string.format("(function(%s) return %s end)(%s)", table.concat(arglist, ","), table.concat(comparisons, chain), table.concat(vals, ","))
  end
  local function define_comparator_special(name, lua_op, chain_op)
    do
      local op = (lua_op or name)
      local function opfn(ast, scope, parent)
        compiler.assert((2 < #ast), "expected at least two arguments", ast)
        if (3 == #ast) then
          return native_comparator(op, ast, scope, parent)
        else
          return double_eval_protected_comparator(op, chain_op, ast, scope, parent)
        end
      end
      SPECIALS[name] = opfn
    end
    return doc_special(name, {"a", "b", "..."}, "Comparison operator; works the same as Lua but accepts more arguments.")
  end
  define_comparator_special(">")
  define_comparator_special("<")
  define_comparator_special(">=")
  define_comparator_special("<=")
  define_comparator_special("=", "==")
  define_comparator_special("not=", "~=", "or")
  SPECIALS["~="] = SPECIALS["not="]
  local function define_unary_special(op, realop)
    local function opfn(ast, scope, parent)
      compiler.assert((#ast == 2), "expected one argument", ast)
      local tail = compiler.compile1(ast[2], scope, parent, {nval = 1})
      return ((realop or op) .. tostring(tail[1]))
    end
    SPECIALS[op] = opfn
    return nil
  end
  define_unary_special("not", "not ")
  doc_special("not", {"x"}, "Logical operator; works the same as Lua.")
  define_unary_special("bnot", "~")
  doc_special("bnot", {"x"}, "Bitwise negation; only works in Lua 5.3+.")
  define_unary_special("length", "#")
  doc_special("length", {"x"}, "Returns the length of a table or string.")
  SPECIALS["#"] = SPECIALS.length
  SPECIALS.quote = function(ast, scope, parent)
    compiler.assert((#ast == 2), "expected one argument")
    local runtime, this_scope = true, scope
    while this_scope do
      this_scope = this_scope.parent
      if (this_scope == compiler.scopes.compiler) then
        runtime = false
      end
    end
    return compiler["do-quote"](ast[2], scope, parent, runtime)
  end
  doc_special("quote", {"x"}, "Quasiquote the following form. Only works in macro/compiler scope.")
  local already_warned_3f = {}
  local compile_env_warning = ("WARNING: Attempting to %s %s in compile" .. " scope.\nIn future versions of Fennel this will not" .. " be allowed without the\n--no-compiler-sandbox flag" .. " or passing :compiler-env _G in options.\n")
  local function compiler_env_warn(_, key)
    local v = _G[key]
    if (v and io and io.stderr and not already_warned_3f[key]) then
      already_warned_3f[key] = true
      do end (io.stderr):write(compile_env_warning:format("use global", key))
    end
    return v
  end
  local safe_compiler_env = setmetatable({assert = assert, bit = _G.bit, error = error, getmetatable = getmetatable, ipairs = ipairs, math = math, next = next, pairs = pairs, pcall = pcall, print = print, rawequal = rawequal, rawget = rawget, rawlen = _G.rawlen, rawset = rawset, select = select, setmetatable = setmetatable, string = string, table = table, tonumber = tonumber, tostring = tostring, type = type, xpcall = xpcall}, {__index = compiler_env_warn})
  local function make_compiler_env(ast, scope, parent)
    local function _1_()
      return compiler.scopes.macro
    end
    local function _2_(symbol)
      compiler.assert(compiler.scopes.macro, "must call from macro", ast)
      return compiler.scopes.macro.manglings[tostring(symbol)]
    end
    local function _3_(base)
      return utils.sym(compiler.gensym((compiler.scopes.macro or scope), base))
    end
    local function _4_(form)
      compiler.assert(compiler.scopes.macro, "must call from macro", ast)
      return compiler.macroexpand(form, compiler.scopes.macro)
    end
    local _6_
    do
      local _5_0 = utils.root.options
      if ((type(_5_0) == "table") and (nil ~= _5_0["compiler-env"])) then
        local compiler_env = _5_0["compiler-env"]
        _6_ = compiler_env
      else
        local _ = _5_0
        _6_ = safe_compiler_env
      end
    end
    return setmetatable({["assert-compile"] = compiler.assert, ["get-scope"] = _1_, ["in-scope?"] = _2_, ["list?"] = utils["list?"], ["multi-sym?"] = utils["multi-sym?"], ["sequence?"] = utils["sequence?"], ["sym?"] = utils["sym?"], ["table?"] = utils["table?"], ["varg?"] = utils["varg?"], _AST = ast, _CHUNK = parent, _IS_COMPILER = true, _SCOPE = scope, _SPECIALS = compiler.scopes.global.specials, _VARARG = utils.varg(), gensym = _3_, list = utils.list, macroexpand = _4_, sequence = utils.sequence, sym = utils.sym, unpack = unpack}, {__index = _6_})
  end
  local cfg = string.gmatch(package.config, "([^\n]+)")
  local dirsep, pathsep, pathmark = (cfg() or "/"), (cfg() or ";"), (cfg() or "?")
  local pkg_config = {dirsep = dirsep, pathmark = pathmark, pathsep = pathsep}
  local function escapepat(str)
    return string.gsub(str, "[^%w]", "%%%1")
  end
  local function search_module(modulename, pathstring)
    local pathsepesc = escapepat(pkg_config.pathsep)
    local pattern = ("([^%s]*)%s"):format(pathsepesc, pathsepesc)
    local no_dot_module = modulename:gsub("%.", pkg_config.dirsep)
    local fullpath = ((pathstring or utils["fennel-module"].path) .. pkg_config.pathsep)
    local function try_path(path)
      local filename = path:gsub(escapepat(pkg_config.pathmark), no_dot_module)
      local filename2 = path:gsub(escapepat(pkg_config.pathmark), modulename)
      local _1_0 = (io.open(filename) or io.open(filename2))
      if (nil ~= _1_0) then
        local file = _1_0
        file:close()
        return filename
      end
    end
    local function find_in_path(start)
      local _1_0 = fullpath:match(pattern, start)
      if (nil ~= _1_0) then
        local path = _1_0
        return (try_path(path) or find_in_path((start + #path + 1)))
      end
    end
    return find_in_path(1)
  end
  local function make_searcher(options)
    local function _1_(module_name)
      local opts = utils.copy(utils.root.options)
      for k, v in pairs((options or {})) do
        opts[k] = v
      end
      local _2_0 = search_module(module_name)
      if (nil ~= _2_0) then
        local filename = _2_0
        local function _3_(...)
          return utils["fennel-module"].dofile(filename, opts, ...)
        end
        return _3_, filename
      end
    end
    return _1_
  end
  local function macro_globals(env, globals)
    local allowed = current_global_names(env)
    for _, k in pairs((globals or {})) do
      table.insert(allowed, k)
    end
    return allowed
  end
  local function compiler_env_domodule(modname, env, _3fast)
    local filename = compiler.assert(search_module(modname), (modname .. " module not found."), _3fast)
    local globals = macro_globals(env, current_global_names())
    return utils["fennel-module"].dofile(filename, {allowedGlobals = globals, env = env, scope = compiler.scopes.compiler, useMetadata = utils.root.options.useMetadata}, modname, filename)
  end
  local macro_loaded = {}
  local function metadata_only_fennel(modname)
    if ((modname == "fennel.macros") or (package and package.loaded and ("table" == type(package.loaded[modname])) and (package.loaded[modname].metadata == compiler.metadata))) then
      return {metadata = compiler.metadata}
    end
  end
  safe_compiler_env.require = function(modname)
    local function _1_()
      local mod = compiler_env_domodule(modname, safe_compiler_env)
      macro_loaded[modname] = mod
      return mod
    end
    return (macro_loaded[modname] or metadata_only_fennel(modname) or _1_())
  end
  local function add_macros(macros_2a, ast, scope)
    compiler.assert(utils["table?"](macros_2a), "expected macros to be table", ast)
    for k, v in pairs(macros_2a) do
      compiler.assert((type(v) == "function"), "expected each macro to be function", ast)
      scope.macros[k] = v
    end
    return nil
  end
  SPECIALS["require-macros"] = function(ast, scope, parent)
    compiler.assert((#ast == 2), "Expected one module name argument", ast)
    local modname = ast[2]
    if not macro_loaded[modname] then
      local env = make_compiler_env(ast, scope, parent)
      macro_loaded[modname] = compiler_env_domodule(modname, env, ast)
    end
    return add_macros(macro_loaded[modname], ast, scope, parent)
  end
  doc_special("require-macros", {"macro-module-name"}, "Load given module and use its contents as macro definitions in current scope.\nMacro module should return a table of macro functions with string keys.\nConsider using import-macros instead as it is more flexible.")
  local function emit_included_fennel(src, path, opts, sub_chunk)
    local subscope = compiler["make-scope"](utils.root.scope.parent)
    local forms = {}
    if utils.root.options.requireAsInclude then
      subscope.specials.require = compiler["require-include"]
    end
    for _, val in parser.parser(parser["string-stream"](src), path) do
      table.insert(forms, val)
    end
    for i = 1, #forms do
      local subopts = nil
      if (i == #forms) then
        subopts = {tail = true}
      else
        subopts = {nval = 0}
      end
      utils["propagate-options"](opts, subopts)
      compiler.compile1(forms[i], subscope, sub_chunk, subopts)
    end
    return nil
  end
  local function include_path(ast, opts, path, mod, fennel_3f)
    utils.root.scope.includes[mod] = "fnl/loading"
    local src = nil
    do
      local f = assert(io.open(path))
      local function close_handlers_0_(ok_0_, ...)
        f:close()
        if ok_0_ then
          return ...
        else
          return error(..., 0)
        end
      end
      local function _1_()
        return f:read("*all"):gsub("[\13\n]*$", "")
      end
      src = close_handlers_0_(xpcall(_1_, (package.loaded.fennel or debug).traceback))
    end
    local ret = utils.expr(("require(\"" .. mod .. "\")"), "statement")
    local target = ("package.preload[%q]"):format(mod)
    local preload_str = (target .. " = " .. target .. " or function(...)")
    local temp_chunk, sub_chunk = {}, {}
    compiler.emit(temp_chunk, preload_str, ast)
    compiler.emit(temp_chunk, sub_chunk)
    compiler.emit(temp_chunk, "end", ast)
    for i, v in ipairs(temp_chunk) do
      table.insert(utils.root.chunk, i, v)
    end
    if fennel_3f then
      emit_included_fennel(src, path, opts, sub_chunk)
    else
      compiler.emit(sub_chunk, src, ast)
    end
    utils.root.scope.includes[mod] = ret
    return ret
  end
  local function include_circular_fallback(mod, modexpr, fallback, ast)
    if (utils.root.scope.includes[mod] == "fnl/loading") then
      compiler.assert(fallback, "circular include detected", ast)
      return fallback(modexpr)
    end
  end
  SPECIALS.include = function(ast, scope, parent, opts)
    compiler.assert((#ast == 2), "expected one argument", ast)
    local modexpr = compiler.compile1(ast[2], scope, parent, {nval = 1})[1]
    if ((modexpr.type ~= "literal") or ((modexpr[1]):byte() ~= 34)) then
      if opts.fallback then
        return opts.fallback(modexpr)
      else
        return compiler.assert(false, "module name must be string literal", ast)
      end
    else
      local mod = load_code(("return " .. modexpr[1]))()
      local function _2_()
        local _1_0 = search_module(mod)
        if (nil ~= _1_0) then
          local fennel_path = _1_0
          return include_path(ast, opts, fennel_path, mod, true)
        else
          local _ = _1_0
          local lua_path = search_module(mod, package.path)
          if lua_path then
            return include_path(ast, opts, lua_path, mod, false)
          elseif opts.fallback then
            return opts.fallback(modexpr)
          else
            return compiler.assert(false, ("module not found " .. mod), ast)
          end
        end
      end
      return (include_circular_fallback(mod, modexpr, opts.fallback, ast) or utils.root.scope.includes[mod] or _2_())
    end
  end
  doc_special("include", {"module-name-literal"}, "Like require but load the target module during compilation and embed it in the\nLua output. The module must be a string literal and resolvable at compile time.")
  local function eval_compiler_2a(ast, scope, parent)
    local env = make_compiler_env(ast, scope, parent)
    local opts = utils.copy(utils.root.options)
    opts.scope = compiler["make-scope"](compiler.scopes.compiler)
    opts.allowedGlobals = macro_globals(env, current_global_names())
    return load_code(compiler.compile(ast, opts), wrap_env(env))()
  end
  SPECIALS.macros = function(ast, scope, parent)
    compiler.assert((#ast == 2), "Expected one table argument", ast)
    return add_macros(eval_compiler_2a(ast[2], scope, parent), ast, scope, parent)
  end
  doc_special("macros", {"{:macro-name-1 (fn [...] ...) ... :macro-name-N macro-body-N}"}, "Define all functions in the given table as macros local to the current scope.")
  SPECIALS["eval-compiler"] = function(ast, scope, parent)
    local old_first = ast[1]
    ast[1] = utils.sym("do")
    local val = eval_compiler_2a(ast, scope, parent)
    ast[1] = old_first
    return val
  end
  doc_special("eval-compiler", {"..."}, "Evaluate the body at compile-time. Use the macro system instead if possible.")
  return {["current-global-names"] = current_global_names, ["load-code"] = load_code, ["macro-loaded"] = macro_loaded, ["make-compiler-env"] = make_compiler_env, ["make-searcher"] = make_searcher, ["search-module"] = search_module, ["wrap-env"] = wrap_env, doc = doc_2a}
end
package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or function(...)
  local utils = require("fennel.utils")
  local parser = require("fennel.parser")
  local friend = require("fennel.friend")
  local unpack = (_G.unpack or table.unpack)
  local scopes = {}
  local function make_scope(parent)
    local parent0 = (parent or scopes.global)
    local _0_
    if parent0 then
      _0_ = ((parent0.depth or 0) + 1)
    else
      _0_ = 0
    end
    return {autogensyms = {}, depth = _0_, hashfn = (parent0 and parent0.hashfn), includes = setmetatable({}, {__index = (parent0 and parent0.includes)}), macros = setmetatable({}, {__index = (parent0 and parent0.macros)}), manglings = setmetatable({}, {__index = (parent0 and parent0.manglings)}), parent = parent0, refedglobals = setmetatable({}, {__index = (parent0 and parent0.refedglobals)}), specials = setmetatable({}, {__index = (parent0 and parent0.specials)}), symmeta = setmetatable({}, {__index = (parent0 and parent0.symmeta)}), unmanglings = setmetatable({}, {__index = (parent0 and parent0.unmanglings)}), vararg = (parent0 and parent0.vararg)}
  end
  local function assert_compile(condition, msg, ast)
    if not condition then
      local _0_ = (utils.root.options or {})
      local source = _0_["source"]
      local unfriendly = _0_["unfriendly"]
      utils.root.reset()
      if unfriendly then
        local m = getmetatable(ast)
        local filename = ((m and m.filename) or ast.filename or "unknown")
        local line = ((m and m.line) or ast.line or "?")
        local target = nil
        local function _1_()
          if utils["sym?"](ast[1]) then
            return utils.deref(ast[1])
          else
            return (ast[1] or "()")
          end
        end
        target = tostring(_1_())
        error(string.format("Compile error in '%s' %s:%s: %s", target, filename, line, msg), 0)
      else
        friend["assert-compile"](condition, msg, ast, source)
      end
    end
    return condition
  end
  scopes.global = make_scope()
  scopes.global.vararg = true
  scopes.compiler = make_scope(scopes.global)
  scopes.macro = scopes.global
  local serialize_subst = {["\11"] = "\\v", ["\12"] = "\\f", ["\7"] = "\\a", ["\8"] = "\\b", ["\9"] = "\\t", ["\n"] = "n"}
  local function serialize_string(str)
    local function _0_(_241)
      return ("\\" .. _241:byte())
    end
    return string.gsub(string.gsub(string.format("%q", str), ".", serialize_subst), "[\128-\255]", _0_)
  end
  local function global_mangling(str)
    if utils["valid-lua-identifier?"](str) then
      return str
    else
      local function _0_(_241)
        return string.format("_%02x", _241:byte())
      end
      return ("__fnl_global__" .. str:gsub("[^%w]", _0_))
    end
  end
  local function global_unmangling(identifier)
    local _0_0 = string.match(identifier, "^__fnl_global__(.*)$")
    if (nil ~= _0_0) then
      local rest = _0_0
      local _1_0 = nil
      local function _2_(_241)
        return string.char(tonumber(_241:sub(2), 16))
      end
      _1_0 = string.gsub(rest, "_[%da-f][%da-f]", _2_)
      return _1_0
    else
      local _ = _0_0
      return identifier
    end
  end
  local allowed_globals = nil
  local function global_allowed(name)
    return (not allowed_globals or utils["member?"](name, allowed_globals))
  end
  local function unique_mangling(original, mangling, scope, append)
    if scope.unmanglings[mangling] then
      return unique_mangling(original, (original .. append), scope, (append + 1))
    else
      return mangling
    end
  end
  local function local_mangling(str, scope, ast, temp_manglings)
    assert_compile(not utils["multi-sym?"](str), ("unexpected multi symbol " .. str), ast)
    local raw = nil
    if (utils["lua-keywords"][str] or str:match("^%d")) then
      raw = ("_" .. str)
    else
      raw = str
    end
    local mangling = nil
    local function _1_(_241)
      return string.format("_%02x", _241:byte())
    end
    mangling = string.gsub(string.gsub(raw, "-", "_"), "[^%w_]", _1_)
    local unique = unique_mangling(mangling, mangling, scope, 0)
    scope.unmanglings[unique] = str
    do
      local manglings = (temp_manglings or scope.manglings)
      manglings[str] = unique
    end
    return unique
  end
  local function apply_manglings(scope, new_manglings, ast)
    for raw, mangled in pairs(new_manglings) do
      assert_compile(not scope.refedglobals[mangled], ("use of global " .. raw .. " is aliased by a local"), ast)
      scope.manglings[raw] = mangled
    end
    return nil
  end
  local function combine_parts(parts, scope)
    local ret = (scope.manglings[parts[1]] or global_mangling(parts[1]))
    for i = 2, #parts do
      if utils["valid-lua-identifier?"](parts[i]) then
        if (parts["multi-sym-method-call"] and (i == #parts)) then
          ret = (ret .. ":" .. parts[i])
        else
          ret = (ret .. "." .. parts[i])
        end
      else
        ret = (ret .. "[" .. serialize_string(parts[i]) .. "]")
      end
    end
    return ret
  end
  local function gensym(scope, base)
    local append, mangling = 0, ((base or "") .. "_0_")
    while scope.unmanglings[mangling] do
      mangling = ((base or "") .. "_" .. append .. "_")
      append = (append + 1)
    end
    scope.unmanglings[mangling] = (base or true)
    return mangling
  end
  local function autogensym(base, scope)
    local _0_0 = utils["multi-sym?"](base)
    if (nil ~= _0_0) then
      local parts = _0_0
      parts[1] = autogensym(parts[1], scope)
      return table.concat(parts, ((parts["multi-sym-method-call"] and ":") or "."))
    else
      local _ = _0_0
      local function _1_()
        local mangling = gensym(scope, base:sub(1, ( - 2)))
        scope.autogensyms[base] = mangling
        return mangling
      end
      return (scope.autogensyms[base] or _1_())
    end
  end
  local function check_binding_valid(symbol, scope, ast)
    local name = utils.deref(symbol)
    assert_compile(not (scope.specials[name] or scope.macros[name]), ("local %s was overshadowed by a special form or macro"):format(name), ast)
    return assert_compile(not utils["quoted?"](symbol), string.format("macro tried to bind %s without gensym", name), symbol)
  end
  local function declare_local(symbol, meta, scope, ast, temp_manglings)
    check_binding_valid(symbol, scope, ast)
    local name = utils.deref(symbol)
    assert_compile(not utils["multi-sym?"](name), ("unexpected multi symbol " .. name), ast)
    scope.symmeta[name] = meta
    return local_mangling(name, scope, ast, temp_manglings)
  end
  local function hashfn_arg_name(name, multi_sym_parts, scope)
    if not scope.hashfn then
      return nil
    elseif (name == "$") then
      return "$1"
    elseif multi_sym_parts then
      if (multi_sym_parts and (multi_sym_parts[1] == "$")) then
        multi_sym_parts[1] = "$1"
      end
      return table.concat(multi_sym_parts, ".")
    end
  end
  local function symbol_to_expression(symbol, scope, reference_3f)
    utils.hook("symbol-to-expression", symbol, scope, reference_3f)
    local name = symbol[1]
    local multi_sym_parts = utils["multi-sym?"](name)
    local name0 = (hashfn_arg_name(name, multi_sym_parts, scope) or name)
    local parts = (multi_sym_parts or {name0})
    local etype = (((#parts > 1) and "expression") or "sym")
    local local_3f = scope.manglings[parts[1]]
    if (local_3f and scope.symmeta[parts[1]]) then
      scope.symmeta[parts[1]]["used"] = true
    end
    assert_compile((not reference_3f or local_3f or global_allowed(parts[1])), ("unknown global in strict mode: " .. parts[1]), symbol)
    if (allowed_globals and not local_3f) then
      utils.root.scope.refedglobals[parts[1]] = true
    end
    return utils.expr(combine_parts(parts, scope), etype)
  end
  local function emit(chunk, out, ast)
    if (type(out) == "table") then
      return table.insert(chunk, out)
    else
      return table.insert(chunk, {ast = ast, leaf = out})
    end
  end
  local function peephole(chunk)
    if chunk.leaf then
      return chunk
    elseif ((#chunk >= 3) and (chunk[(#chunk - 2)].leaf == "do") and not chunk[(#chunk - 1)].leaf and (chunk[#chunk].leaf == "end")) then
      local kid = peephole(chunk[(#chunk - 1)])
      local new_chunk = {ast = chunk.ast}
      for i = 1, (#chunk - 3) do
        table.insert(new_chunk, peephole(chunk[i]))
      end
      for i = 1, #kid do
        table.insert(new_chunk, kid[i])
      end
      return new_chunk
    else
      return utils.map(chunk, peephole)
    end
  end
  local function flatten_chunk_correlated(main_chunk)
    local function flatten(chunk, out, last_line, file)
      local last_line0 = last_line
      if chunk.leaf then
        out[last_line0] = ((out[last_line0] or "") .. " " .. chunk.leaf)
      else
        for _, subchunk in ipairs(chunk) do
          if (subchunk.leaf or (#subchunk > 0)) then
            if (subchunk.ast and (file == subchunk.ast.file)) then
              last_line0 = math.max(last_line0, (subchunk.ast.line or 0))
            end
            last_line0 = flatten(subchunk, out, last_line0, file)
          end
        end
      end
      return last_line0
    end
    local out = {}
    local last = flatten(main_chunk, out, 1, main_chunk.file)
    for i = 1, last do
      if (out[i] == nil) then
        out[i] = ""
      end
    end
    return table.concat(out, "\n")
  end
  local function flatten_chunk(sm, chunk, tab, depth)
    if chunk.leaf then
      local code = chunk.leaf
      local info = chunk.ast
      if sm then
        table.insert(sm, ((info and info.line) or ( - 1)))
      end
      return code
    else
      local tab0 = nil
      do
        local _0_0 = tab
        if (_0_0 == true) then
          tab0 = "  "
        elseif (_0_0 == false) then
          tab0 = ""
        elseif (_0_0 == tab) then
          tab0 = tab
        elseif (_0_0 == nil) then
          tab0 = ""
        else
        tab0 = nil
        end
      end
      local function parter(c)
        if (c.leaf or (#c > 0)) then
          local sub = flatten_chunk(sm, c, tab0, (depth + 1))
          if (depth > 0) then
            return (tab0 .. sub:gsub("\n", ("\n" .. tab0)))
          else
            return sub
          end
        end
      end
      return table.concat(utils.map(chunk, parter), "\n")
    end
  end
  local fennel_sourcemap = {}
  local function make_short_src(source)
    local source0 = source:gsub("\n", " ")
    if (#source0 <= 49) then
      return ("[fennel \"" .. source0 .. "\"]")
    else
      return ("[fennel \"" .. source0:sub(1, 46) .. "...\"]")
    end
  end
  local function flatten(chunk, options)
    local chunk0 = peephole(chunk)
    if options.correlate then
      return flatten_chunk_correlated(chunk0), {}
    else
      local sm = {}
      local ret = flatten_chunk(sm, chunk0, options.indent, 0)
      if sm then
        sm.short_src = make_short_src((options.filename or options.source or ret))
        if options.filename then
          sm.key = ("@" .. options.filename)
        else
          sm.key = ret
        end
        fennel_sourcemap[sm.key] = sm
      end
      return ret, sm
    end
  end
  local function make_metadata()
    local function _0_(self, tgt, key)
      if self[tgt] then
        return self[tgt][key]
      end
    end
    local function _1_(self, tgt, key, value)
      self[tgt] = (self[tgt] or {})
      self[tgt][key] = value
      return tgt
    end
    local function _2_(self, tgt, ...)
      local kv_len = select("#", ...)
      local kvs = {...}
      if ((kv_len % 2) ~= 0) then
        error("metadata:setall() expected even number of k/v pairs")
      end
      self[tgt] = (self[tgt] or {})
      for i = 1, kv_len, 2 do
        self[tgt][kvs[i]] = kvs[(i + 1)]
      end
      return tgt
    end
    return setmetatable({}, {__index = {get = _0_, set = _1_, setall = _2_}, __mode = "k"})
  end
  local function exprs1(exprs)
    return table.concat(utils.map(exprs, 1), ", ")
  end
  local function keep_side_effects(exprs, chunk, start, ast)
    local start0 = (start or 1)
    for j = start0, #exprs do
      local se = exprs[j]
      if ((se.type == "expression") and (se[1] ~= "nil")) then
        emit(chunk, string.format("do local _ = %s end", tostring(se)), ast)
      elseif (se.type == "statement") then
        local code = tostring(se)
        emit(chunk, (((code:byte() == 40) and ("do end " .. code)) or code), ast)
      end
    end
    return nil
  end
  local function handle_compile_opts(exprs, parent, opts, ast)
    if opts.nval then
      local n = opts.nval
      local len = #exprs
      if (n ~= len) then
        if (len > n) then
          keep_side_effects(exprs, parent, (n + 1), ast)
          for i = (n + 1), len do
            exprs[i] = nil
          end
        else
          for i = (#exprs + 1), n do
            exprs[i] = utils.expr("nil", "literal")
          end
        end
      end
    end
    if opts.tail then
      emit(parent, string.format("return %s", exprs1(exprs)), ast)
    end
    if opts.target then
      local result = exprs1(exprs)
      local function _2_()
        if (result == "") then
          return "nil"
        else
          return result
        end
      end
      emit(parent, string.format("%s = %s", opts.target, _2_()), ast)
    end
    if (opts.tail or opts.target) then
      return {returned = true}
    else
      local _3_0 = exprs
      _3_0["returned"] = true
      return _3_0
    end
  end
  local function find_macro(ast, scope, multi_sym_parts)
    local function find_in_table(t, i)
      if (i <= #multi_sym_parts) then
        return find_in_table((utils["table?"](t) and t[multi_sym_parts[i]]), (i + 1))
      else
        return t
      end
    end
    local macro_2a = (utils["sym?"](ast[1]) and scope.macros[utils.deref(ast[1])])
    if (not macro_2a and multi_sym_parts) then
      local nested_macro = find_in_table(scope.macros, 1)
      assert_compile((not scope.macros[multi_sym_parts[1]] or (type(nested_macro) == "function")), "macro not found in imported macro module", ast)
      return nested_macro
    else
      return macro_2a
    end
  end
  local function macroexpand_2a(ast, scope, once)
    if not utils["list?"](ast) then
      return ast
    else
      local macro_2a = find_macro(ast, scope, utils["multi-sym?"](ast[1]))
      if not macro_2a then
        return ast
      else
        local old_scope = scopes.macro
        local _ = nil
        scopes.macro = scope
        _ = nil
        local ok, transformed = pcall(macro_2a, unpack(ast, 2))
        scopes.macro = old_scope
        assert_compile(ok, transformed, ast)
        if (once or not transformed) then
          return transformed
        else
          return macroexpand_2a(transformed, scope)
        end
      end
    end
  end
  local function compile_special(ast, scope, parent, opts, special)
    local exprs = (special(ast, scope, parent, opts) or utils.expr("nil", "literal"))
    local exprs0 = nil
    if (type(exprs) == "string") then
      exprs0 = utils.expr(exprs, "expression")
    else
      exprs0 = exprs
    end
    local exprs2 = nil
    if utils["expr?"](exprs0) then
      exprs2 = {exprs0}
    else
      exprs2 = exprs0
    end
    if not exprs2.returned then
      return handle_compile_opts(exprs2, parent, opts, ast)
    elseif (opts.tail or opts.target) then
      return {returned = true}
    else
      return exprs2
    end
  end
  local function compile_function_call(ast, scope, parent, opts, compile1, len)
    local fargs = {}
    local fcallee = compile1(ast[1], scope, parent, {nval = 1})[1]
    assert_compile((fcallee.type ~= "literal"), ("cannot call literal value " .. tostring(ast[1])), ast)
    for i = 2, len do
      local subexprs = nil
      local _0_
      if (i ~= len) then
        _0_ = 1
      else
      _0_ = nil
      end
      subexprs = compile1(ast[i], scope, parent, {nval = _0_})
      table.insert(fargs, (subexprs[1] or utils.expr("nil", "literal")))
      if (i == len) then
        for j = 2, #subexprs do
          table.insert(fargs, subexprs[j])
        end
      else
        keep_side_effects(subexprs, parent, 2, ast[i])
      end
    end
    local call = string.format("%s(%s)", tostring(fcallee), exprs1(fargs))
    return handle_compile_opts({utils.expr(call, "statement")}, parent, opts, ast)
  end
  local function compile_call(ast, scope, parent, opts, compile1)
    utils.hook("call", ast, scope)
    local len = #ast
    local first = ast[1]
    local multi_sym_parts = utils["multi-sym?"](first)
    local special = (utils["sym?"](first) and scope.specials[utils.deref(first)])
    assert_compile((len > 0), "expected a function, macro, or special to call", ast)
    if special then
      return compile_special(ast, scope, parent, opts, special)
    elseif (multi_sym_parts and multi_sym_parts["multi-sym-method-call"]) then
      local table_with_method = table.concat({unpack(multi_sym_parts, 1, (#multi_sym_parts - 1))}, ".")
      local method_to_call = multi_sym_parts[#multi_sym_parts]
      local new_ast = utils.list(utils.sym(":", scope), utils.sym(table_with_method, scope), method_to_call, select(2, unpack(ast)))
      return compile1(new_ast, scope, parent, opts)
    else
      return compile_function_call(ast, scope, parent, opts, compile1, len)
    end
  end
  local function compile_varg(ast, scope, parent, opts)
    assert_compile(scope.vararg, "unexpected vararg", ast)
    return handle_compile_opts({utils.expr("...", "varg")}, parent, opts, ast)
  end
  local function compile_sym(ast, scope, parent, opts)
    local multi_sym_parts = utils["multi-sym?"](ast)
    assert_compile(not (multi_sym_parts and multi_sym_parts["multi-sym-method-call"]), "multisym method calls may only be in call position", ast)
    local e = nil
    if (ast[1] == "nil") then
      e = utils.expr("nil", "literal")
    else
      e = symbol_to_expression(ast, scope, true)
    end
    return handle_compile_opts({e}, parent, opts, ast)
  end
  local function compile_scalar(ast, _scope, parent, opts)
    local serialize = nil
    do
      local _0_0 = type(ast)
      if (_0_0 == "nil") then
        serialize = tostring
      elseif (_0_0 == "boolean") then
        serialize = tostring
      elseif (_0_0 == "string") then
        serialize = serialize_string
      elseif (_0_0 == "number") then
        local function _1_(...)
          return string.format("%.17g", ...)
        end
        serialize = _1_
      else
      serialize = nil
      end
    end
    return handle_compile_opts({utils.expr(serialize(ast), "literal")}, parent, opts)
  end
  local function compile_table(ast, scope, parent, opts, compile1)
    local buffer = {}
    for i = 1, #ast do
      local nval = ((i ~= #ast) and 1)
      table.insert(buffer, exprs1(compile1(ast[i], scope, parent, {nval = nval})))
    end
    local function write_other_values(k)
      if ((type(k) ~= "number") or (math.floor(k) ~= k) or (k < 1) or (k > #ast)) then
        if ((type(k) == "string") and utils["valid-lua-identifier?"](k)) then
          return {k, k}
        else
          local _0_ = compile1(k, scope, parent, {nval = 1})
          local compiled = _0_[1]
          local kstr = ("[" .. tostring(compiled) .. "]")
          return {kstr, k}
        end
      end
    end
    do
      local keys = nil
      do
        local _0_0 = utils.kvmap(ast, write_other_values)
        local function _1_(a, b)
          return (a[1] < b[1])
        end
        table.sort(_0_0, _1_)
        keys = _0_0
      end
      local function _1_(k)
        local v = tostring(compile1(ast[k[2]], scope, parent, {nval = 1})[1])
        return string.format("%s = %s", k[1], v)
      end
      utils.map(keys, _1_, buffer)
    end
    return handle_compile_opts({utils.expr(("{" .. table.concat(buffer, ", ") .. "}"), "expression")}, parent, opts, ast)
  end
  local function compile1(ast, scope, parent, opts)
    local opts0 = (opts or {})
    local ast0 = macroexpand_2a(ast, scope)
    if utils["list?"](ast0) then
      return compile_call(ast0, scope, parent, opts0, compile1)
    elseif utils["varg?"](ast0) then
      return compile_varg(ast0, scope, parent, opts0)
    elseif utils["sym?"](ast0) then
      return compile_sym(ast0, scope, parent, opts0)
    elseif (type(ast0) == "table") then
      return compile_table(ast0, scope, parent, opts0, compile1)
    elseif ((type(ast0) == "nil") or (type(ast0) == "boolean") or (type(ast0) == "number") or (type(ast0) == "string")) then
      return compile_scalar(ast0, scope, parent, opts0)
    else
      return assert_compile(false, ("could not compile value of type " .. type(ast0)), ast0)
    end
  end
  local function destructure(to, from, ast, scope, parent, opts)
    local opts0 = (opts or {})
    local _0_ = opts0
    local declaration = _0_["declaration"]
    local forceglobal = _0_["forceglobal"]
    local forceset = _0_["forceset"]
    local isvar = _0_["isvar"]
    local nomulti = _0_["nomulti"]
    local noundef = _0_["noundef"]
    local setter = nil
    if declaration then
      setter = "local %s = %s"
    else
      setter = "%s = %s"
    end
    local new_manglings = {}
    local function getname(symbol, up1)
      local raw = symbol[1]
      assert_compile(not (nomulti and utils["multi-sym?"](raw)), ("unexpected multi symbol " .. raw), up1)
      if declaration then
        return declare_local(symbol, nil, scope, symbol, new_manglings)
      else
        local parts = (utils["multi-sym?"](raw) or {raw})
        local meta = scope.symmeta[parts[1]]
        if ((#parts == 1) and not forceset) then
          assert_compile(not (forceglobal and meta), string.format("global %s conflicts with local", tostring(symbol)), symbol)
          assert_compile(not (meta and not meta.var), ("expected var " .. raw), symbol)
          assert_compile((meta or not noundef), ("expected local " .. parts[1]), symbol)
        end
        if forceglobal then
          assert_compile(not scope.symmeta[scope.unmanglings[raw]], ("global " .. raw .. " conflicts with local"), symbol)
          scope.manglings[raw] = global_mangling(raw)
          scope.unmanglings[global_mangling(raw)] = raw
          if allowed_globals then
            table.insert(allowed_globals, raw)
          end
        end
        return symbol_to_expression(symbol, scope)[1]
      end
    end
    local function compile_top_target(lvalues)
      local inits = nil
      local function _2_(_241)
        if scope.manglings[_241] then
          return _241
        else
          return "nil"
        end
      end
      inits = utils.map(lvalues, _2_)
      local init = table.concat(inits, ", ")
      local lvalue = table.concat(lvalues, ", ")
      local plen, plast = #parent, parent[#parent]
      local ret = compile1(from, scope, parent, {target = lvalue})
      if declaration then
        for pi = plen, #parent do
          if (parent[pi] == plast) then
            plen = pi
          end
          return scopes.global.specials['include'](ast, scope, parent, opts)
      end
  
      local function compileStream(strm, options)
          local opts = utils.copy(options)
          local oldGlobals = allowedGlobals
          utils.root:setReset()
          allowedGlobals = opts.allowedGlobals
          if opts.indent == nil then opts.indent = '  ' end
          local scope = opts.scope or makeScope(scopes.global)
          if opts.requireAsInclude then scope.specials.require = requireInclude end
          local vals = {}
          for ok, val in parser.parser(strm, opts.filename, opts) do
              if not ok then break end
              vals[#vals + 1] = val
        end
        if ((#parent == (plen + 1)) and parent[#parent].leaf) then
          parent[#parent]["leaf"] = ("local " .. parent[#parent].leaf)
        else
          table.insert(parent, (plen + 1), {ast = ast, leaf = ("local " .. lvalue .. " = " .. init)})
        end
      end
      return ret
    end
    local function destructure1(left, rightexprs, up1, top_3f)
      if (utils["sym?"](left) and (left[1] ~= "nil")) then
        local lname = getname(left, up1)
        check_binding_valid(left, scope, left)
        if top_3f then
          compile_top_target({lname})
        else
          emit(parent, setter:format(lname, exprs1(rightexprs)), left)
        end
        if declaration then
          scope.symmeta[utils.deref(left)] = {var = isvar}
        end
      elseif utils["table?"](left) then
        local s = gensym(scope)
        local right = nil
        if top_3f then
          right = exprs1(compile1(from, scope, parent))
        else
          right = exprs1(rightexprs)
        end
        if (right == "") then
          right = "nil"
        end
        emit(parent, string.format("local %s = %s", s, right), left)
        for k, v in utils.stablepairs(left) do
          if (utils["sym?"](left[k]) and (left[k][1] == "&")) then
            assert_compile(((type(k) == "number") and not left[(k + 2)]), "expected rest argument before last parameter", left)
            local unpack_str = "{(table.unpack or unpack)(%s, %s)}"
            local formatted = string.format(unpack_str, s, k)
            local subexpr = utils.expr(formatted, "expression")
            destructure1(left[(k + 1)], {subexpr}, left)
            return
          else
            local key = nil
            if (type(k) == "string") then
              key = serialize_string(k)
            else
              key = k
            end
            local subexpr = utils.expr(string.format("%s[%s]", s, key), "expression")
            destructure1(v, {subexpr}, left)
          end
          local chunk = {}
          utils.root.chunk, utils.root.scope, utils.root.options = chunk, scope, opts
          for i = 1, #vals do
              local exprs = compile1(vals[i], scope, chunk, {
                  tail = i == #vals,
                  nval = i < #vals and 0 or nil
              })
              keepSideEffects(exprs, chunk, nil, vals[i])
        end
      elseif utils["list?"](left) then
        local left_names, tables = {}, {}
        for i, name in ipairs(left) do
          if utils["sym?"](name) then
            table.insert(left_names, getname(name, up1))
          else
            local symname = gensym(scope)
            table.insert(left_names, symname)
            tables[i] = {name, utils.expr(symname, "sym")}
          end
          allowedGlobals = oldGlobals
          utils.root.reset()
          return flatten(chunk, opts)
      end
  
      local function compileString(str, options)
          options = options or {}
          local oldSource = options.source
          options.source = str -- used by fennelfriend
          local ast = compileStream(parser.stringStream(str), options)
          options.source = oldSource
          return ast
      end
  
      local function compile(ast, options)
          local opts = utils.copy(options)
          local oldGlobals = allowedGlobals
          utils.root:setReset()
          allowedGlobals = opts.allowedGlobals
          if opts.indent == nil then opts.indent = '  ' end
          local chunk = {}
          local scope = opts.scope or makeScope(scopes.global)
          utils.root.chunk, utils.root.scope, utils.root.options = chunk, scope, opts
          if opts.requireAsInclude then scope.specials.require = requireInclude end
          local exprs = compile1(ast, scope, chunk, {tail = true})
          keepSideEffects(exprs, chunk, nil, ast)
          allowedGlobals = oldGlobals
          utils.root.reset()
          return flatten(chunk, opts)
      end
  
      -- A custom traceback function for Fennel that looks similar to
      -- the Lua's debug.traceback.
      -- Use with xpcall to produce fennel specific stacktraces.
      local function traceback(msg, start)
          local level = start or 2 -- Can be used to skip some frames
          local lines = {}
          if msg then
              if msg:find("^Compile error") or msg:find("^Parse error") then
                  -- End users don't want to see compiler stack traces, but when
                  -- you're hacking on the compiler, export FENNEL_DEBUG=trace
                  if not utils.debugOn("trace") then return msg end
                  table.insert(lines, msg)
              else
                  local newmsg = msg:gsub('^[^:]*:%d+:%s+', 'runtime error: ')
                  table.insert(lines, newmsg)
              end
        end
        assert_compile(top_3f, "can't nest multi-value destructuring", left)
        compile_top_target(left_names)
        if declaration then
          for _, sym in ipairs(left) do
            scope.symmeta[utils.deref(sym)] = {var = isvar}
          end
          table.insert(lines, 'stack traceback:')
          while true do
              local info = debug.getinfo(level, "Sln")
              if not info then break end
              local line
              if info.what == "C" then
                  if info.name then
                      line = ('  [C]: in function \'%s\''):format(info.name)
                  else
                      line = '  [C]: in ?'
                  end
              else
                  local remap = fennelSourcemap[info.source]
                  if remap and remap[info.currentline] then
                      -- And some global info
                      info.short_src = remap.short_src
                      local mapping = remap[info.currentline]
                      -- Overwrite info with values from the mapping (mapping is now
                      -- just integer, but may eventually be a table)
                      info.currentline = mapping
                  end
                  if info.what == 'Lua' then
                      local n = info.name and ("'" .. info.name .. "'") or '?'
                      line = ('  %s:%d: in function %s'):format(info.short_src, info.currentline, n)
                  elseif info.short_src == '(tail call)' then
                      line = '  (tail call)'
                  else
                      line = ('  %s:%d: in main chunk'):format(info.short_src, info.currentline)
                  end
              end
              table.insert(lines, line)
              level = level + 1
        end
        for _, pair in utils.stablepairs(tables) do
          destructure1(pair[1], {pair[2]}, left)
        end
      else
        assert_compile(false, string.format("unable to bind %s %s", type(left), tostring(left)), (((type(up1[2]) == "table") and up1[2]) or up1))
      end
      if top_3f then
        return {returned = true}
      end
    end
    local ret = destructure1(to, nil, ast, true)
    utils.hook("destructure", from, to, scope)
    apply_manglings(scope, new_manglings, ast)
    return ret
  end
  local function require_include(ast, scope, parent, opts)
    opts.fallback = function(e)
      return utils.expr(string.format("require(%s)", tostring(e)), "statement")
    end
    return scopes.global.specials.include(ast, scope, parent, opts)
  end
  local function compile_stream(strm, options)
    local opts = utils.copy(options)
    local old_globals = allowed_globals
    local scope = (opts.scope or make_scope(scopes.global))
    local vals = {}
    local chunk = {}
    local _0_ = utils.root
    _0_["set-reset"](_0_)
    allowed_globals = opts.allowedGlobals
    if (opts.indent == nil) then
      opts.indent = "  "
    end
    if opts.requireAsInclude then
      scope.specials.require = require_include
    end
    utils.root.chunk, utils.root.scope, utils.root.options = chunk, scope, opts
    for _, val in parser.parser(strm, opts.filename, opts) do
      table.insert(vals, val)
    end
    for i = 1, #vals do
      local exprs = compile1(vals[i], scope, chunk, {nval = (((i < #vals) and 0) or nil), tail = (i == #vals)})
      keep_side_effects(exprs, chunk, nil, vals[i])
    end
    allowed_globals = old_globals
    utils.root.reset()
    return flatten(chunk, opts)
  end
  local function compile_string(str, opts)
    return compile_stream(parser["string-stream"](str), (opts or {}))
  end
  local function compile(ast, opts)
    local opts0 = utils.copy(opts)
    local old_globals = allowed_globals
    local chunk = {}
    local scope = (opts0.scope or make_scope(scopes.global))
    local _0_ = utils.root
    _0_["set-reset"](_0_)
    allowed_globals = opts0.allowedGlobals
    if (opts0.indent == nil) then
      opts0.indent = "  "
    end
    if opts0.requireAsInclude then
      scope.specials.require = require_include
    end
    utils.root.chunk, utils.root.scope, utils.root.options = chunk, scope, opts0
    local exprs = compile1(ast, scope, chunk, {tail = true})
    keep_side_effects(exprs, chunk, nil, ast)
    allowed_globals = old_globals
    utils.root.reset()
    return flatten(chunk, opts0)
  end
  local function traceback_frame(info)
    if ((info.what == "C") and info.name) then
      return string.format("  [C]: in function '%s'", info.name)
    elseif (info.what == "C") then
      return "  [C]: in ?"
    else
      local remap = fennel_sourcemap[info.source]
      if (remap and remap[info.currentline]) then
        info["short-src"] = remap["short-src"]
        info.currentline = remap[info.currentline]
      end
      if (info.what == "Lua") then
        local function _1_()
          if info.name then
            return ("'" .. info.name .. "'")
          else
            return "?"
          end
          return table.concat(lines, '\n')
      end
  
      -- make a transformer for key / value table pairs, preserving all numeric keys
      local function entryTransform(fk,fv)
          return function(k, v)
              if type(k) == 'number' then
                  return k,fv(v)
              else
                  return fk(k),fv(v)
              end
        end
        return string.format("  %s:%d: in function %s", info.short_src, info.currentline, _1_())
      elseif (info["short-src"] == "(tail call)") then
        return "  (tail call)"
      else
        return string.format("  %s:%d: in main chunk", info.short_src, info.currentline)
      end
    end
  end
  local function traceback(msg, start)
    local msg0 = (msg or "")
    if ((msg0:find("^Compile error") or msg0:find("^Parse error")) and not utils["debug-on?"]("trace")) then
      return msg0
    else
      local lines = {}
      if (msg0:find("^Compile error") or msg0:find("^Parse error")) then
        table.insert(lines, msg0)
      else
        local newmsg = msg0:gsub("^[^:]*:%d+:%s+", "runtime error: ")
        table.insert(lines, newmsg)
      end
      table.insert(lines, "stack traceback:")
      local done_3f, level = false, (start or 2)
      while not done_3f do
        do
          local _1_0 = debug.getinfo(level, "Sln")
          if (_1_0 == nil) then
            done_3f = true
          elseif (nil ~= _1_0) then
            local info = _1_0
            table.insert(lines, traceback_frame(info))
          end
        end
        level = (level + 1)
      end
      return table.concat(lines, "\n")
    end
  end
  local function entry_transform(fk, fv)
    local function _0_(k, v)
      if (type(k) == "number") then
        return k, fv(v)
      else
        return fk(k), fv(v)
      end
    end
    return _0_
  end
  local function no()
    return nil
  end
  local function mixed_concat(t, joiner)
    local seen = {}
    local ret, s = "", ""
    for k, v in ipairs(t) do
      table.insert(seen, k)
      ret = (ret .. s .. v)
      s = joiner
    end
    for k, v in utils.stablepairs(t) do
      if not seen[k] then
        ret = (ret .. s .. "[" .. k .. "]" .. "=" .. v)
        s = joiner
      end
    end
    return ret
  end
  local function do_quote(form, scope, parent, runtime_3f)
    local function q(x)
      return do_quote(x, scope, parent, runtime_3f)
    end
    if utils["varg?"](form) then
      assert_compile(not runtime_3f, "quoted ... may only be used at compile time", form)
      return "_VARARG"
    elseif utils["sym?"](form) then
      local filename = nil
      if form.filename then
        filename = string.format("%q", form.filename)
      else
        filename = "nil"
      end
      local symstr = utils.deref(form)
      assert_compile(not runtime_3f, "symbols may only be used at compile time", form)
      if (symstr:find("#$") or symstr:find("#[:.]")) then
        return string.format("sym('%s', nil, {filename=%s, line=%s})", autogensym(symstr, scope), filename, (form.line or "nil"))
      else
        return string.format("sym('%s', nil, {quoted=true, filename=%s, line=%s})", symstr, filename, (form.line or "nil"))
      end
    elseif (utils["list?"](form) and utils["sym?"](form[1]) and (utils.deref(form[1]) == "unquote")) then
      local payload = form[2]
      local res = unpack(compile1(payload, scope, parent))
      return res[1]
    elseif utils["list?"](form) then
      local mapped = utils.kvmap(form, entry_transform(no, q))
      local filename = nil
      if form.filename then
        filename = string.format("%q", form.filename)
      else
        filename = "nil"
      end
      assert_compile(not runtime_3f, "lists may only be used at compile time", form)
      return string.format(("setmetatable({filename=%s, line=%s, bytestart=%s, %s}" .. ", getmetatable(list()))"), filename, (form.line or "nil"), (form.bytestart or "nil"), mixed_concat(mapped, ", "))
    elseif (type(form) == "table") then
      local mapped = utils.kvmap(form, entry_transform(q, q))
      local source = getmetatable(form)
      local filename = nil
      if source.filename then
        filename = string.format("%q", source.filename)
      else
        filename = "nil"
      end
      local function _1_()
        if source then
          return source.line
        else
          return "nil"
        end
      end
      return string.format("setmetatable({%s}, {filename=%s, line=%s})", mixed_concat(mapped, ", "), filename, _1_())
    elseif (type(form) == "string") then
      return serialize_string(form)
    else
      return tostring(form)
    end
  end
  return {["apply-manglings"] = apply_manglings, ["compile-stream"] = compile_stream, ["compile-string"] = compile_string, ["declare-local"] = declare_local, ["do-quote"] = do_quote, ["global-mangling"] = global_mangling, ["global-unmangling"] = global_unmangling, ["keep-side-effects"] = keep_side_effects, ["make-scope"] = make_scope, ["require-include"] = require_include, ["symbol-to-expression"] = symbol_to_expression, assert = assert_compile, autogensym = autogensym, compile = compile, compile1 = compile1, destructure = destructure, emit = emit, gensym = gensym, macroexpand = macroexpand_2a, metadata = make_metadata(), scopes = scopes, traceback = traceback}
end
package.preload["fennel.friend"] = package.preload["fennel.friend"] or function(...)
  local function ast_source(ast)
    local m = getmetatable(ast)
    return ((m and m.line and m) or ast or {})
  end
  local suggestions = {["$ and $... in hashfn are mutually exclusive"] = {"modifying the hashfn so it only contains $... or $, $1, $2, $3, etc"}, ["can't start multisym segment with a digit"] = {"removing the digit", "adding a non-digit before the digit"}, ["cannot call literal value"] = {"checking for typos", "checking for a missing function name"}, ["could not compile value of type "] = {"debugging the macro you're calling not to return a coroutine or userdata"}, ["could not read number (.*)"] = {"removing the non-digit character", "beginning the identifier with a non-digit if it is not meant to be a number"}, ["expected a function.* to call"] = {"removing the empty parentheses", "using square brackets if you want an empty table"}, ["expected binding table"] = {"placing a table here in square brackets containing identifiers to bind"}, ["expected body expression"] = {"putting some code in the body of this form after the bindings"}, ["expected each macro to be function"] = {"ensuring that the value for each key in your macros table contains a function", "avoid defining nested macro tables"}, ["expected even number of name/value bindings"] = {"finding where the identifier or value is missing"}, ["expected even number of values in table literal"] = {"removing a key", "adding a value"}, ["expected local"] = {"looking for a typo", "looking for a local which is used out of its scope"}, ["expected macros to be table"] = {"ensuring your macro definitions return a table"}, ["expected parameters"] = {"adding function parameters as a list of identifiers in brackets"}, ["expected rest argument before last parameter"] = {"moving & to right before the final identifier when destructuring"}, ["expected symbol for function parameter: (.*)"] = {"changing %s to an identifier instead of a literal value"}, ["expected var (.*)"] = {"declaring %s using var instead of let/local", "introducing a new local instead of changing the value of %s"}, ["expected vararg as last parameter"] = {"moving the \"...\" to the end of the parameter list"}, ["expected whitespace before opening delimiter"] = {"adding whitespace"}, ["global (.*) conflicts with local"] = {"renaming local %s"}, ["illegal character: (.)"] = {"deleting or replacing %s", "avoiding reserved characters like \", \\, ', ~, ;, @, `, and comma"}, ["local (.*) was overshadowed by a special form or macro"] = {"renaming local %s"}, ["macro not found in macro module"] = {"checking the keys of the imported macro module's returned table"}, ["macro tried to bind (.*) without gensym"] = {"changing to %s# when introducing identifiers inside macros"}, ["malformed multisym"] = {"ensuring each period or colon is not followed by another period or colon"}, ["may only be used at compile time"] = {"moving this to inside a macro if you need to manipulate symbols/lists", "using square brackets instead of parens to construct a table"}, ["method must be last component"] = {"using a period instead of a colon for field access", "removing segments after the colon", "making the method call, then looking up the field on the result"}, ["mismatched closing delimiter (.), expected (.)"] = {"replacing %s with %s", "deleting %s", "adding matching opening delimiter earlier"}, ["multisym method calls may only be in call position"] = {"using a period instead of a colon to reference a table's fields", "putting parens around this"}, ["unable to bind (.*)"] = {"replacing the %s with an identifier"}, ["unexpected closing delimiter (.)"] = {"deleting %s", "adding matching opening delimiter earlier"}, ["unexpected multi symbol (.*)"] = {"removing periods or colons from %s"}, ["unexpected vararg"] = {"putting \"...\" at the end of the fn parameters if the vararg was intended"}, ["unknown global in strict mode: (.*)"] = {"looking to see if there's a typo", "using the _G table instead, eg. _G.%s if you really want a global", "moving this code to somewhere that %s is in scope", "binding %s as a local in the scope of this code"}, ["unused local (.*)"] = {"fixing a typo so %s is used", "renaming the local to _%s"}, ["use of global (.*) is aliased by a local"] = {"renaming local %s", "refer to the global using _G.%s instead of directly"}}
  local unpack = (_G.unpack or table.unpack)
  local function suggest(msg)
    local suggestion = nil
    for pat, sug in pairs(suggestions) do
      local matches = {msg:match(pat)}
      if (0 < #matches) then
        if ("table" == type(sug)) then
          local out = {}
          for _, s in ipairs(sug) do
            table.insert(out, s:format(unpack(matches)))
          end
          suggestion = out
        else
          suggestion = sug(matches)
        end
      end
    end
    return suggestion
  end
  local function read_line_from_file(filename, line)
    local bytes = 0
    local f = assert(io.open(filename))
    local _ = nil
    for _0 = 1, (line - 1) do
      bytes = (bytes + 1 + #f:read())
    end
    _ = nil
    local codeline = f:read()
    f:close()
    return codeline, bytes
  end
  local function read_line_from_source(source, line)
    local lines, bytes, codeline = 0, 0
    for this_line, newline in string.gmatch((source .. "\n"), "(.-)(\13?\n)") do
      lines = (lines + 1)
      if (lines == line) then
        codeline = this_line
        break
      end
      bytes = (bytes + #newline + #this_line)
    end
    return codeline, bytes
  end
  local function read_line(filename, line, source)
    if source then
      return read_line_from_source(source, line)
    else
      return read_line_from_file(filename, line)
    end
  end
  local function friendly_msg(msg, _0_0, source)
    local _1_ = _0_0
    local byteend = _1_["byteend"]
    local bytestart = _1_["bytestart"]
    local filename = _1_["filename"]
    local line = _1_["line"]
    local ok, codeline, bol = pcall(read_line, filename, line, source)
    local suggestions0 = suggest(msg)
    local out = {msg, ""}
    if (ok and codeline) then
      table.insert(out, codeline)
    end
    if (ok and codeline and bytestart and byteend) then
      table.insert(out, (string.rep(" ", (bytestart - bol - 1)) .. "^" .. string.rep("^", math.min((byteend - bytestart), ((bol + #codeline) - bytestart)))))
    end
    if (ok and codeline and bytestart and not byteend) then
      table.insert(out, (string.rep("-", (bytestart - bol - 1)) .. "^"))
      table.insert(out, "")
    end
    if suggestions0 then
      for _, suggestion in ipairs(suggestions0) do
        table.insert(out, ("* Try %s."):format(suggestion))
      end
    end
    return table.concat(out, "\n")
  end
  local function assert_compile(condition, msg, ast, source)
    if not condition then
      local _1_ = ast_source(ast)
      local filename = _1_["filename"]
      local line = _1_["line"]
      error(friendly_msg(("Compile error in %s:%s\n  %s"):format((filename or "unknown"), (line or "?"), msg), ast_source(ast), source), 0)
    end
    return condition
  end
  local function parse_error(msg, filename, line, bytestart, source)
    return error(friendly_msg(("Parse error in %s:%s\n  %s"):format(filename, line, msg), {bytestart = bytestart, filename = filename, line = line}, source), 0)
  end
  return {["assert-compile"] = assert_compile, ["parse-error"] = parse_error}
end
package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(...)
  local utils = require("fennel.utils")
  local friend = require("fennel.friend")
  local unpack = (_G.unpack or table.unpack)
  local function granulate(getchunk)
    local c, index, done_3f = "", 1, false
    local function _0_(parser_state)
      if not done_3f then
        if (index <= #c) then
          local b = c:byte(index)
          index = (index + 1)
          return b
        else
          local _1_0, _2_0, _3_0 = getchunk(parser_state)
          local _4_
          do
            local char = _1_0
            _4_ = ((nil ~= _1_0) and (char ~= ""))
          end
          if _4_ then
            local char = _1_0
            c = char
            index = 2
            return c:byte()
          else
            local _ = _1_0
            done_3f = true
            return nil
          end
        end
      end
    end
    local function _1_()
      c = ""
      return nil
    end
    return _0_, _1_
  end
  local function string_stream(str)
    local str0 = str:gsub("^#![^\n]*\n", "")
    local index = 1
    local function _0_()
      local r = str0:byte(index)
      index = (index + 1)
      return r
    end
    return _0_
  end
  local delims = {[123] = 125, [125] = true, [40] = 41, [41] = true, [91] = 93, [93] = true}
  local function whitespace_3f(b)
    return ((b == 32) or ((b >= 9) and (b <= 13)))
  end
  local function symbolchar_3f(b)
    return ((b > 32) and not delims[b] and (b ~= 127) and (b ~= 34) and (b ~= 39) and (b ~= 126) and (b ~= 59) and (b ~= 44) and (b ~= 64) and (b ~= 96))
  end
  local prefixes = {[35] = "hashfn", [39] = "quote", [44] = "unquote", [96] = "quote"}
  local function parser(getbyte, filename, options)
    local stack = {}
    local line = 1
    local byteindex = 0
    local lastb = nil
    local function ungetb(ub)
      if (ub == 10) then
        line = (line - 1)
      end
      byteindex = (byteindex - 1)
      lastb = ub
      return nil
    end
    local function getb()
      local r = nil
      if lastb then
        r, lastb = lastb, nil
      else
        r = getbyte({["stack-size"] = #stack})
      end
  
      -- consume everything return nothing
      local function no() end
  
      local function mixedConcat(t, joiner)
          local ret = ""
          local s = ""
          local seen = {}
          for k,v in ipairs(t) do
              table.insert(seen, k)
              ret = ret .. s .. v
              s = joiner
          end
          for k,v in utils.stablepairs(t) do
              if not(seen[k]) then
                  ret = ret .. s .. '[' .. k .. ']' .. '=' .. v
                  s = joiner
              end
          end
          return ret
      end
  
      -- expand a quoted form into a data literal, evaluating unquote
      local function doQuote (form, scope, parent, runtime)
          local q = function (x) return doQuote(x, scope, parent, runtime) end
          -- vararg
          if utils.isVarg(form) then
              assertCompile(not runtime, "quoted ... may only be used at compile time", form)
              return "_VARARG"
          -- symbol
          elseif utils.isSym(form) then
              assertCompile(not runtime, "symbols may only be used at compile time", form)
              -- We should be able to use "%q" for this but Lua 5.1 throws an error
              -- when you try to format nil, because it's extremely bad.
              local filename = form.filename and ('%q'):format(form.filename) or "nil"
              if utils.deref(form):find("#$") or utils.deref(form):find("#[:.]") then -- autogensym
                  return ("sym('%s', nil, {filename=%s, line=%s})"):
                      format(autogensym(utils.deref(form), scope), filename, form.line or "nil")
              else -- prevent non-gensymmed symbols from being bound as an identifier
                  return ("sym('%s', nil, {quoted=true, filename=%s, line=%s})"):
                      format(utils.deref(form), filename, form.line or "nil")
              end
          -- unquote
          elseif(utils.isList(form) and utils.isSym(form[1]) and
                 (utils.deref(form[1]) == 'unquote')) then
              local payload = form[2]
              local res = unpack(compile1(payload, scope, parent))
              return res[1]
          -- list
          elseif utils.isList(form) then
              assertCompile(not runtime, "lists may only be used at compile time", form)
              local mapped = utils.kvmap(form, entryTransform(no, q))
              local filename = form.filename and ('%q'):format(form.filename) or "nil"
              -- Constructing a list and then adding file/line data to it triggers a
              -- bug where it changes the value of # for lists that contain nils in
              -- them; constructing the list all in one go with the source data and
              -- contents is how we construct lists in the parser and works around
              -- this problem; allowing # to work in a way that lets us see the nils.
              return ("setmetatable({filename=%s, line=%s, bytestart=%s, %s}" ..
                          ", getmetatable(list()))")
                  :format(filename, form.line or "nil", form.bytestart or "nil",
                          mixedConcat(mapped, ", "))
          -- table
          elseif type(form) == 'table' then
              local mapped = utils.kvmap(form, entryTransform(q, q))
              local source = getmetatable(form)
              local filename = source.filename and ('%q'):format(source.filename) or "nil"
              return ("setmetatable({%s}, {filename=%s, line=%s})"):
                  format(mixedConcat(mapped, ", "), filename, source and source.line or "nil")
          -- string
          elseif type(form) == 'string' then
              return serializeString(form)
          else
              return tostring(form)
          end
      byteindex = (byteindex + 1)
      if (r == 10) then
        line = (line + 1)
      end
      return {
          -- compiling functions:
          compileString=compileString, compileStream=compileStream,
          compile=compile, compile1=compile1, emit=emit, destructure=destructure,
          requireInclude=requireInclude,
  
          -- AST functions:
          gensym=gensym, autogensym=autogensym, doQuote=doQuote,
          macroexpand=macroexpand, globalUnmangling=globalUnmangling,
          applyManglings=applyManglings, globalMangling=globalMangling,
  
          -- scope functions:
          makeScope=makeScope, keepSideEffects=keepSideEffects,
          declareLocal=declareLocal, symbolToExpression=symbolToExpression,
  
          -- general functions:
          assert=assertCompile, metadata=makeMetadata(), traceback=traceback,
          scopes=scopes,
      }
  end)()
  
  --
  -- Specials and macros
  --
  
  local specials = (function()
      local SPECIALS = compiler.scopes.global.specials
  
      -- Convert a fennel environment table to a Lua environment table.
      -- This means automatically unmangling globals when getting a value,
      -- and mangling values when setting a value. This means the original env
      -- will see its values updated as expected, regardless of mangling rules.
      local function wrapEnv(env)
          return setmetatable({}, {
              __index = function(_, key)
                  if type(key) == 'string' then
                      key = compiler.globalUnmangling(key)
                  end
                  return env[key]
              end,
              __newindex = function(_, key, value)
                  if type(key) == 'string' then
                      key = compiler.globalMangling(key)
                  end
                  env[key] = value
              end,
              -- checking the __pairs metamethod won't work automatically in Lua 5.1
              -- sadly, but it's important for 5.2+ and can be done manually in 5.1
              __pairs = function()
                  local function putenv(k, v)
                      return type(k) == 'string' and compiler.globalUnmangling(k) or k, v
                  end
                  local pt = utils.kvmap(env, putenv)
                  return next, pt, nil
              end,
          })
      end
  
      local function currentGlobalNames(env)
          return utils.kvmap(env or _G, compiler.globalUnmangling)
      end
  
      -- Load code with an environment in all recent Lua versions
      local function loadCode(code, environment, filename)
          environment = environment or _ENV or _G
          if setfenv and loadstring then
              local f = assert(loadstring(code, filename))
              setfenv(f, environment)
              return f
          else
              return assert(load(code, filename, "t", environment))
          end
      return r
    end
    local function parse_error(msg, byteindex_override)
      local _0_ = (options or utils.root.options or {})
      local source = _0_["source"]
      local unfriendly = _0_["unfriendly"]
      utils.root.reset()
      if unfriendly then
        return error(string.format("Parse error in %s:%s: %s", (filename or "unknown"), (line or "?"), msg), 0)
      else
        return friend["parse-error"](msg, (filename or "unknown"), (line or "?"), (byteindex_override or byteindex), source)
      end
  
      -- Return a docstring
      local doc = function(tgt, name)
          if(not tgt) then return name .. " not found" end
          local docstring = (compiler.metadata:get(tgt, 'fnl/docstring') or
                                 '#<undocumented>'):gsub('\n$', ''):gsub('\n', '\n  ')
          if type(tgt) == "function" then
              local arglist = table.concat(compiler.metadata:get(tgt, 'fnl/arglist') or
                                               {'#<unknown-arguments>'}, ' ')
              return string.format("(%s%s%s)\n  %s", name, #arglist > 0 and ' ' or '',
                                   arglist, docstring)
          else
              return string.format("%s\n  %s", name, docstring)
          end
    end
    local function parse_stream()
      local whitespace_since_dispatch, done_3f, retval = true
      local function dispatch(v)
        local _0_0 = stack[#stack]
        if (_0_0 == nil) then
          retval, done_3f, whitespace_since_dispatch = v, true, false
          return nil
        elseif ((type(_0_0) == "table") and (nil ~= _0_0.prefix)) then
          local prefix = _0_0.prefix
          table.remove(stack)
          return dispatch(utils.list(utils.sym(prefix), v))
        elseif (nil ~= _0_0) then
          local top = _0_0
          whitespace_since_dispatch = false
          return table.insert(top, v)
        end
      end
  
      local function docSpecial(name, arglist, docstring)
          compiler.metadata[SPECIALS[name]] =
              { ["fnl/docstring"] = docstring, ["fnl/arglist"] = arglist }
      end
  
      -- Compile a list of forms for side effects
      local function compileDo(ast, scope, parent, start)
          start = start or 2
          local len = #ast
          local subScope = compiler.makeScope(scope)
          for i = start, len do
              compiler.compile1(ast[i], subScope, parent, {
                  nval = 0
              })
          end
      local function badend()
        local accum = utils.map(stack, "closer")
        local _0_
        if (#stack == 1) then
          _0_ = ""
        else
          _0_ = "s"
        end
        return parse_error(string.format("expected closing delimiter%s %s", _0_, string.char(unpack(accum))))
      end
      local function skip_whitespace(b)
        if (b and whitespace_3f(b)) then
          whitespace_since_dispatch = true
          return skip_whitespace(getb())
        elseif (not b and (#stack > 0)) then
          return badend()
        else
          return b
        end
      end
  
      -- Implements a do statement, starting at the 'start' element. By default, start is 2.
      local function doImpl(ast, scope, parent, opts, start, chunk, subScope, preSyms)
          start = start or 2
          subScope = subScope or compiler.makeScope(scope)
          chunk = chunk or {}
          local len = #ast
          local outerTarget = opts.target
          local outerTail = opts.tail
          local retexprs = {returned = true}
  
          -- See if we need special handling to get the return values
          -- of the do block
          if not outerTarget and opts.nval ~= 0 and not outerTail then
              if opts.nval then
                  -- Generate a local target
                  local syms = {}
                  for i = 1, opts.nval do
                      local s = preSyms and preSyms[i] or compiler.gensym(scope)
                      syms[i] = s
                      retexprs[i] = utils.expr(s, 'sym')
                  end
                  outerTarget = table.concat(syms, ', ')
                  compiler.emit(parent, ('local %s'):format(outerTarget), ast)
                  compiler.emit(parent, 'do', ast)
              else
                  -- We will use an IIFE for the do
                  local fname = compiler.gensym(scope)
                  local fargs = scope.vararg and '...' or ''
                  compiler.emit(parent, ('local function %s(%s)'):format(fname, fargs), ast)
                  retexprs = utils.expr(fname .. '(' .. fargs .. ')', 'statement')
                  outerTail = true
                  outerTarget = nil
              end
          else
              compiler.emit(parent, 'do', ast)
          end
          -- Compile the body
          if start > len then
              -- In the unlikely case we do a do with no arguments.
              compiler.compile1(nil, subScope, chunk, {
                  tail = outerTail,
                  target = outerTarget
              })
              -- There will be no side effects
          else
              for i = start, len do
                  local subopts = {
                      nval = i ~= len and 0 or opts.nval,
                      tail = i == len and outerTail or nil,
                      target = i == len and outerTarget or nil
                  }
                  utils.propagateOptions(opts, subopts)
                  local subexprs = compiler.compile1(ast[i], subScope, chunk, subopts)
                  if i ~= len then
                      compiler.keepSideEffects(subexprs, parent, nil, ast[i])
                  end
              end
          end
          compiler.emit(parent, chunk, ast)
          compiler.emit(parent, 'end', ast)
          return retexprs
      end
  
      SPECIALS["do"] = doImpl
      docSpecial("do", {"..."}, "Evaluate multiple forms; return last value.")
  
      -- Unlike most expressions and specials, 'values' resolves with multiple
      -- values, one for each argument, allowing multiple return values. The last
      -- expression can return multiple arguments as well, allowing for more than
      -- the number of expected arguments.
      SPECIALS["values"] = function(ast, scope, parent)
          local len = #ast
          local exprs = {}
          for i = 2, len do
              local subexprs = compiler.compile1(ast[i], scope, parent, {
                  nval = (i ~= len) and 1
              })
              exprs[#exprs + 1] = subexprs[1]
              if i == len then
                  for j = 2, #subexprs do
                      exprs[#exprs + 1] = subexprs[j]
                  end
              end
          end
          return exprs
      end
      docSpecial("values", {"..."},
                 "Return multiple values from a function.  Must be in tail position.")
  
      -- The fn special declares a function. Syntax is similar to other lisps;
      -- (fn optional-name [arg ...] (body))
      -- Further decoration such as docstrings, meta info, and multibody functions a possibility.
      SPECIALS["fn"] = function(ast, scope, parent)
          local fScope = compiler.makeScope(scope)
          local fChunk = {}
          local index = 2
          local fnName = utils.isSym(ast[index])
          local isLocalFn
          local docstring
          fScope.vararg = false
          local multi = fnName and utils.isMultiSym(fnName[1])
          compiler.assert(not multi or not multi.multiSymMethodCall,
                        "unexpected multi symbol " .. tostring(fnName), ast[index])
          if fnName and fnName[1] ~= 'nil' then
              isLocalFn = not multi
              if isLocalFn then
                  fnName = compiler.declareLocal(fnName, {}, scope, ast)
              else
                  fnName = compiler.symbolToExpression(fnName, scope)[1]
              end
              index = index + 1
          else
              isLocalFn = true
              fnName = compiler.gensym(scope)
          end
          local argList = compiler.assert(utils.isTable(ast[index]),
                                        "expected parameters",
                                        type(ast[index]) == "table" and ast[index] or ast)
          local function getArgName(i, name)
              if utils.isVarg(name) then
                  compiler.assert(i == #argList, "expected vararg as last parameter", ast[2])
                  fScope.vararg = true
                  return "..."
              elseif(utils.isSym(name) and utils.deref(name) ~= "nil"
                     and not utils.isMultiSym(utils.deref(name))) then
                  return compiler.declareLocal(name, {}, fScope, ast)
              elseif utils.isTable(name) then
                  local raw = utils.sym(compiler.gensym(scope))
                  local declared = compiler.declareLocal(raw, {}, fScope, ast)
                  compiler.destructure(name, raw, ast, fScope, fChunk,
                                       { declaration = true, nomulti = true })
                  return declared
              else
                  compiler.assert(false, ("expected symbol for function parameter: %s"):
                                    format(tostring(name)), ast[2])
              end
          end
          local argNameList = utils.kvmap(argList, getArgName)
          if type(ast[index + 1]) == 'string' and index + 1 < #ast then
              index = index + 1
              docstring = ast[index]
          end
          for i = index + 1, #ast do
              compiler.compile1(ast[i], fScope, fChunk, {
                  tail = i == #ast,
                  nval = i ~= #ast and 0 or nil,
              })
          end
          if isLocalFn then
              compiler.emit(parent, ('local function %s(%s)')
                       :format(fnName, table.concat(argNameList, ', ')), ast)
          else
              compiler.emit(parent, ('%s = function(%s)')
                       :format(fnName, table.concat(argNameList, ', ')), ast)
          end
  
          compiler.emit(parent, fChunk, ast)
          compiler.emit(parent, 'end', ast)
  
          if utils.root.options.useMetadata then
              local args = utils.map(argList, function(v)
                  -- TODO: show destructured args properly instead of replacing
                  return utils.isTable(v) and '"#<table>"' or string.format('"%s"', tostring(v))
              end)
  
              local metaFields = {
                  '"fnl/arglist"', '{' .. table.concat(args, ', ') .. '}',
              }
              if docstring then
                  table.insert(metaFields, '"fnl/docstring"')
                  table.insert(metaFields, '"' .. docstring:gsub('%s+$', '')
                                   :gsub('\\', '\\\\'):gsub('\n', '\\n')
                                   :gsub('"', '\\"') .. '"')
              end
              local metaStr = ('require("%s").metadata'):
                  format(utils.root.options.moduleName or "fennel")
              compiler.emit(parent, string.format('pcall(function() %s:setall(%s, %s) end)',
                                         metaStr, fnName, table.concat(metaFields, ', ')))
          end
  
          return utils.expr(fnName, 'sym')
      end
      docSpecial("fn", {"name?", "args", "docstring?", "..."},
                 "Function syntax. May optionally include a name and docstring."
                     .."\nIf a name is provided, the function will be bound in the current scope."
                     .."\nWhen called with the wrong number of args, excess args will be discarded"
                     .."\nand lacking args will be nil, use lambda for arity-checked functions.")
  
      -- (lua "print('hello!')") -> prints hello, evaluates to nil
      -- (lua "print 'hello!'" "10") -> prints hello, evaluates to the number 10
      -- (lua nil "{1,2,3}") -> Evaluates to a table literal
      SPECIALS['lua'] = function(ast, _, parent)
          compiler.assert(#ast == 2 or #ast == 3, "expected 1 or 2 arguments", ast)
          if ast[2] ~= nil then
              table.insert(parent, {leaf = tostring(ast[2]), ast = ast})
          end
          if #ast == 3 then
              return tostring(ast[3])
          end
      local function skip_comment(b)
        if (b and (10 ~= b)) then
          return skip_comment(getb())
        else
          return b
        end
      end
  
      SPECIALS['doc'] = function(ast, scope, parent)
          assert(utils.root.options.useMetadata, "can't look up doc with metadata disabled.")
          compiler.assert(#ast == 2, "expected one argument", ast)
  
          local target = utils.deref(ast[2])
          local specialOrMacro = scope.specials[target] or scope.macros[target]
          if specialOrMacro then
              return ("print([[%s]])"):format(doc(specialOrMacro, target))
          else
              local value = tostring(compiler.compile1(ast[2], scope, parent, {nval = 1})[1])
              -- need to require here since the metadata is stored in the module
              -- and we need to make sure we look it up in the same module it was
              -- declared from.
              return ("print(require('%s').doc(%s, '%s'))")
                  :format(utils.root.options.moduleName or "fennel", value, tostring(ast[2]))
          end
      local function open_table(b)
        if not whitespace_since_dispatch then
          parse_error(("expected whitespace before opening delimiter " .. string.char(b)))
        end
        return table.insert(stack, {bytestart = byteindex, closer = delims[b], filename = filename, line = line})
      end
      docSpecial("doc", {"x"},
                 "Print the docstring and arglist for a function, macro, or special form.")
  
      -- Table lookup
      SPECIALS["."] = function(ast, scope, parent)
          local len = #ast
          compiler.assert(len > 1, "expected table argument", ast)
          local lhs = compiler.compile1(ast[2], scope, parent, {nval = 1})
          if len == 2 then
              return tostring(lhs[1])
          else
              local indices = {}
              for i = 3, len do
                  local index = ast[i]
                  if type(index) == 'string' and utils.isValidLuaIdentifier(index) then
                      table.insert(indices, '.' .. index)
                  else
                      index = compiler.compile1(index, scope, parent, {nval = 1})[1]
                      table.insert(indices, '[' .. tostring(index) .. ']')
                  end
              end
              -- extra parens are needed for table literals
              if utils.isTable(ast[2]) then
                  return '(' .. tostring(lhs[1]) .. ')' .. table.concat(indices)
              else
                  return tostring(lhs[1]) .. table.concat(indices)
              end
          end
      local function close_list(list)
        return dispatch(setmetatable(list, getmetatable(utils.list())))
      end
      docSpecial(".", {"tbl", "key1", "..."},
                 "Look up key1 in tbl table. If more args are provided, do a nested lookup.")
  
      SPECIALS["global"] = function(ast, scope, parent)
          compiler.assert(#ast == 3, "expected name and value", ast)
          compiler.destructure(ast[2], ast[3], ast, scope, parent, {
              nomulti = true,
              forceglobal = true
          })
      end
      docSpecial("global", {"name", "val"}, "Set name as a global with val.")
  
      SPECIALS["set"] = function(ast, scope, parent)
          compiler.assert(#ast == 3, "expected name and value", ast)
          compiler.destructure(ast[2], ast[3], ast, scope, parent, {
              noundef = true
          })
      end
      docSpecial("set", {"name", "val"},
                 "Set a local variable to a new value. Only works on locals using var.")
  
      SPECIALS["set-forcibly!"] = function(ast, scope, parent)
          compiler.assert(#ast == 3, "expected name and value", ast)
          compiler.destructure(ast[2], ast[3], ast, scope, parent, {
              forceset = true
          })
      end
  
      SPECIALS["local"] = function(ast, scope, parent)
          compiler.assert(#ast == 3, "expected name and value", ast)
          compiler.destructure(ast[2], ast[3], ast, scope, parent, {
              declaration = true,
              nomulti = true
          })
      end
      docSpecial("local", {"name", "val"},
                 "Introduce new top-level immutable local.")
  
      SPECIALS["var"] = function(ast, scope, parent)
          compiler.assert(#ast == 3, "expected name and value", ast)
          compiler.destructure(ast[2], ast[3], ast, scope, parent, {
                                   declaration = true, nomulti = true, isvar = true })
      end
      docSpecial("var", {"name", "val"},
                 "Introduce new mutable local.")
  
      SPECIALS["let"] = function(ast, scope, parent, opts)
          local bindings = ast[2]
          compiler.assert(utils.isList(bindings) or utils.isTable(bindings),
                        "expected binding table", ast)
          compiler.assert(#bindings % 2 == 0,
                        "expected even number of name/value bindings", ast[2])
          compiler.assert(#ast >= 3, "expected body expression", ast[1])
          -- we have to gensym the binding for the let body's return value before
          -- compiling the binding vector, otherwise there's a possibility to conflict
          local preSyms = {}
          for _ = 1, (opts.nval or 0) do table.insert(preSyms, compiler.gensym(scope)) end
          local subScope = compiler.makeScope(scope)
          local subChunk = {}
          for i = 1, #bindings, 2 do
              compiler.destructure(bindings[i], bindings[i + 1], ast, subScope, subChunk, {
                                       declaration = true, nomulti = true })
          end
          return doImpl(ast, scope, parent, opts, 3, subChunk, subScope, preSyms)
      end
      docSpecial("let", {"[name1 val1 ... nameN valN]", "..."},