garden/fennel.lua

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 view = require("fennel.view")
  local unpack = (table.unpack or _G.unpack)
  local function default_read_chunk(parser_state)
    local function _604_()
      if (0 < parser_state["stack-size"]) then
        return ".."
      else
        return ">> "
      end
    end
    io.write(_604_())
    io.flush()
    local input = io.read()
    return (input and (input .. "\n"))
  end
  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 _606_()
      local _605_0 = errtype
      if (_605_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 (_605_0 == "Runtime") then
        return (compiler.traceback(tostring(err), 4) .. "\n")
      else
        local _ = _605_0
        return ("%s error: %s\n"):format(errtype, tostring(err))
      end
    end
    return io.write(_606_())
  end
  local function splice_save_locals(env, lua_source, scope)
    local saves = nil
    do
      local tbl_17_ = {}
      local i_18_ = #tbl_17_
      for name in pairs(env.___replLocals___) do
        local val_19_ = ("local %s = ___replLocals___['%s']"):format((scope.manglings[name] or name), name)
        if (nil ~= val_19_) then
          i_18_ = (i_18_ + 1)
          tbl_17_[i_18_] = val_19_
        end
      end
      saves = tbl_17_
    end
    local binds = nil
    do
      local tbl_17_ = {}
      local i_18_ = #tbl_17_
      for raw, name in pairs(scope.manglings) do
        local val_19_ = nil
        if not scope.gensyms[name] then
          val_19_ = ("___replLocals___['%s'] = %s"):format(raw, name)
        else
        val_19_ = nil
        end
        if (nil ~= val_19_) then
          i_18_ = (i_18_ + 1)
          tbl_17_[i_18_] = val_19_
        end
      end
      binds = tbl_17_
    end
    local gap = nil
    if lua_source:find("\n") then
      gap = "\n"
    else
      gap = " "
    end
    local function _612_()
      if next(saves) then
        return (table.concat(saves, " ") .. gap)
      else
        return ""
      end
    end
    local function _615_()
      local _613_0, _614_0 = lua_source:match("^(.*)[\n ](return .*)$")
      if ((nil ~= _613_0) and (nil ~= _614_0)) then
        local body = _613_0
        local _return = _614_0
        return (body .. gap .. table.concat(binds, " ") .. gap .. _return)
      else
        local _ = _613_0
        return lua_source
      end
    end
    return (_612_() .. _615_())
  end
  local function completer(env, scope, text)
    local max_items = 2000
    local seen = {}
    local matches = {}
    local input_fragment = text:gsub(".*[%s)(]+", "")
    local stop_looking_3f = false
    local function add_partials(input, tbl, prefix)
      local scope_first_3f = ((tbl == env) or (tbl == env.___replLocals___))
      local tbl_17_ = matches
      local i_18_ = #tbl_17_
      local function _617_()
        if scope_first_3f then
          return scope.manglings
        else
          return tbl
        end
      end
      for k, is_mangled in utils.allpairs(_617_()) do
        if (max_items <= #matches) then break end
        local val_19_ = nil
        do
          local lookup_k = nil
          if scope_first_3f then
            lookup_k = is_mangled
          else
            lookup_k = k
          end
          if ((type(k) == "string") and (input == k:sub(0, #input)) and not seen[k] and ((":" ~= prefix:sub(-1)) or ("function" == type(tbl[lookup_k])))) then
            seen[k] = true
            val_19_ = (prefix .. k)
          else
          val_19_ = nil
          end
        end
        if (nil ~= val_19_) then
          i_18_ = (i_18_ + 1)
          tbl_17_[i_18_] = val_19_
        end
      end
      return tbl_17_
    end
    local function descend(input, tbl, prefix, add_matches, method_3f)
      local splitter = nil
      if method_3f then
        splitter = "^([^:]+):(.*)"
      else
        splitter = "^([^.]+)%.(.*)"
      end
      local head, tail = input:match(splitter)
      local raw_head = (scope.manglings[head] or head)
      if (type(tbl[raw_head]) == "table") then
        stop_looking_3f = true
        if method_3f then
          return add_partials(tail, tbl[raw_head], (prefix .. head .. ":"))
        else
          return add_matches(tail, tbl[raw_head], (prefix .. head))
        end
      end
    end
    local function add_matches(input, tbl, prefix)
      local prefix0 = nil
      if prefix then
        prefix0 = (prefix .. ".")
      else
        prefix0 = ""
      end
      if (not input:find("%.") and input:find(":")) then
        return descend(input, tbl, prefix0, add_matches, true)
      elseif not input:find("%.") then
        return add_partials(input, tbl, prefix0)
      else
        return descend(input, tbl, prefix0, add_matches, false)
      end
    end
    for _, source in ipairs({scope.specials, scope.macros, (env.___replLocals___ or {}), env, env._G}) do
      if stop_looking_3f then break end
      add_matches(input_fragment, source)
    end
    return matches
  end
  local commands = {}
  local function command_3f(input)
    return input:match("^%s*,")
  end
  local function command_docs()
    local _626_
    do
      local tbl_17_ = {}
      local i_18_ = #tbl_17_
      for name, f in pairs(commands) do
        local val_19_ = ("  ,%s - %s"):format(name, ((compiler.metadata):get(f, "fnl/docstring") or "undocumented"))
        if (nil ~= val_19_) then
          i_18_ = (i_18_ + 1)
          tbl_17_[i_18_] = val_19_
        end
      end
      _626_ = tbl_17_
    end
    return table.concat(_626_, "\n")
  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" .. command_docs() .. "\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
  do end (compiler.metadata):set(commands.help, "fnl/docstring", "Show this message.")
  local function reload(module_name, env, on_values, on_error)
    local _628_0, _629_0 = pcall(specials["load-code"]("return require(...)", env), module_name)
    if ((_628_0 == true) and (nil ~= _629_0)) then
      local old = _629_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
      specials["macro-loaded"][module_name] = nil
      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
        end
        package.loaded[module_name] = old
      end
      return on_values({"ok"})
    elseif ((_628_0 == false) and (nil ~= _629_0)) then
      local msg = _629_0
      if msg:match("loop or previous error loading module") then
        package.loaded[module_name] = nil
        return reload(module_name, env, on_values, on_error)
      elseif specials["macro-loaded"][module_name] then
        specials["macro-loaded"][module_name] = nil
        return nil
      else
        local function _634_()
          local _633_0 = msg:gsub("\n.*", "")
          return _633_0
        end
        return on_error("Runtime", _634_())
      end
    end
  end
  local function run_command(read, on_error, f)
    local _637_0, _638_0, _639_0 = pcall(read)
    if ((_637_0 == true) and (_638_0 == true) and (nil ~= _639_0)) then
      local val = _639_0
      local _640_0, _641_0 = pcall(f, val)
      if ((_640_0 == false) and (nil ~= _641_0)) then
        local msg = _641_0
        return on_error("Runtime", msg)
      end
    elseif (_637_0 == false) then
      return on_error("Parse", "Couldn't parse input.")
    end
  end
  commands.reload = function(env, read, on_values, on_error)
    local function _644_(_241)
      return reload(tostring(_241), env, on_values, on_error)
    end
    return run_command(read, on_error, _644_)
  end
  do end (compiler.metadata):set(commands.reload, "fnl/docstring", "Reload the specified module.")
  commands.reset = function(env, _, on_values)
    env.___replLocals___ = {}
    return on_values({"ok"})
  end
  do end (compiler.metadata):set(commands.reset, "fnl/docstring", "Erase all repl-local scope.")
  commands.complete = function(env, read, on_values, on_error, scope, chars)
    local function _645_()
      return on_values(completer(env, scope, table.concat(chars):gsub(",complete +", ""):sub(1, -2)))
    end
    return run_command(read, on_error, _645_)
  end
  do end (compiler.metadata):set(commands.complete, "fnl/docstring", "Print all possible completions for a given input symbol.")
  local function apropos_2a(pattern, tbl, prefix, seen, names)
    for name, subtbl in pairs(tbl) do
      if (("string" == type(name)) and (package ~= subtbl)) then
        local _646_0 = type(subtbl)
        if (_646_0 == "function") then
          if ((prefix .. name)):match(pattern) then
            table.insert(names, (prefix .. name))
          end
        elseif (_646_0 == "table") then
          if not seen[subtbl] then
            local _648_
            do
              seen[subtbl] = true
              _648_ = seen
            end
            apropos_2a(pattern, subtbl, (prefix .. name:gsub("%.", "/") .. "."), _648_, names)
          end
        end
      end
    end
    return names
  end
  local function apropos(pattern)
    local names = apropos_2a(pattern, package.loaded, "", {}, {})
    local tbl_17_ = {}
    local i_18_ = #tbl_17_
    for _, name in ipairs(names) do
      local val_19_ = name:gsub("^_G%.", "")
      if (nil ~= val_19_) then
        i_18_ = (i_18_ + 1)
        tbl_17_[i_18_] = val_19_
      end
    end
    return tbl_17_
  end
  commands.apropos = function(_env, read, on_values, on_error, _scope)
    local function _653_(_241)
      return on_values(apropos(tostring(_241)))
    end
    return run_command(read, on_error, _653_)
  end
  do end (compiler.metadata):set(commands.apropos, "fnl/docstring", "Print all functions matching a pattern in all loaded modules.")
  local function apropos_follow_path(path)
    local paths = nil
    do
      local tbl_17_ = {}
      local i_18_ = #tbl_17_
      for p in path:gmatch("[^%.]+") do
        local val_19_ = p
        if (nil ~= val_19_) then
          i_18_ = (i_18_ + 1)
          tbl_17_[i_18_] = val_19_
        end
      end
      paths = tbl_17_
    end
    local tgt = package.loaded
    for _, path0 in ipairs(paths) do
      if (nil == tgt) then break end
      local _656_
      do
        local _655_0 = path0:gsub("%/", ".")
        _656_ = _655_0
      end
      tgt = tgt[_656_]
    end
    return tgt
  end
  local function apropos_doc(pattern)
    local tbl_17_ = {}
    local i_18_ = #tbl_17_
    for _, path in ipairs(apropos(".*")) do
      local val_19_ = nil
      do
        local tgt = apropos_follow_path(path)
        if ("function" == type(tgt)) then
          local _657_0 = (compiler.metadata):get(tgt, "fnl/docstring")
          if (nil ~= _657_0) then
            local docstr = _657_0
            val_19_ = (docstr:match(pattern) and path)
          else
          val_19_ = nil
          end
        else
        val_19_ = nil
        end
      end
      if (nil ~= val_19_) then
        i_18_ = (i_18_ + 1)
        tbl_17_[i_18_] = val_19_
      end
    end
    return tbl_17_
  end
  commands["apropos-doc"] = function(_env, read, on_values, on_error, _scope)
    local function _661_(_241)
      return on_values(apropos_doc(tostring(_241)))
    end
    return run_command(read, on_error, _661_)
  end
  do end (compiler.metadata):set(commands["apropos-doc"], "fnl/docstring", "Print all functions that match the pattern in their docs")
  local function apropos_show_docs(on_values, pattern)
    for _, path in ipairs(apropos(pattern)) do
      local tgt = apropos_follow_path(path)
      if (("function" == type(tgt)) and (compiler.metadata):get(tgt, "fnl/docstring")) then
        on_values(specials.doc(tgt, path))
        on_values()
      end
    end
    return nil
  end
  commands["apropos-show-docs"] = function(_env, read, on_values, on_error)
    local function _663_(_241)
      return apropos_show_docs(on_values, tostring(_241))
    end
    return run_command(read, on_error, _663_)
  end
  do end (compiler.metadata):set(commands["apropos-show-docs"], "fnl/docstring", "Print all documentations matching a pattern in function name")
  local function resolve(identifier, _664_0, scope)
    local _665_ = _664_0
    local env = _665_
    local ___replLocals___ = _665_["___replLocals___"]
    local e = nil
    local function _666_(_241, _242)
      return (___replLocals___[scope.unmanglings[_242]] or env[_242])
    end
    e = setmetatable({}, {__index = _666_})
    local function _667_(...)
      local _668_0, _669_0 = ...
      if ((_668_0 == true) and (nil ~= _669_0)) then
        local code = _669_0
        local function _670_(...)
          local _671_0, _672_0 = ...
          if ((_671_0 == true) and (nil ~= _672_0)) then
            local val = _672_0
            return val
          else
            local _ = _671_0
            return nil
          end
        end
        return _670_(pcall(specials["load-code"](code, e)))
      else
        local _ = _668_0
        return nil
      end
    end
    return _667_(pcall(compiler["compile-string"], tostring(identifier), {scope = scope}))
  end
  commands.find = function(env, read, on_values, on_error, scope)
    local function _675_(_241)
      local _676_0 = nil
      do
        local _677_0 = utils["sym?"](_241)
        if (nil ~= _677_0) then
          local _678_0 = resolve(_677_0, env, scope)
          if (nil ~= _678_0) then
            _676_0 = debug.getinfo(_678_0)
          else
            _676_0 = _678_0
          end
        else
          _676_0 = _677_0
        end
      end
      if ((_G.type(_676_0) == "table") and (nil ~= _676_0.linedefined) and (nil ~= _676_0.short_src) and (nil ~= _676_0.source) and (_676_0.what == "Lua")) then
        local line = _676_0.linedefined
        local src = _676_0.short_src
        local source = _676_0.source
        local fnlsrc = nil
        do
          local _681_0 = compiler.sourcemap
          if (nil ~= _681_0) then
            _681_0 = _681_0[source]
          end
          if (nil ~= _681_0) then
            _681_0 = _681_0[line]
          end
          if (nil ~= _681_0) then
            _681_0 = _681_0[2]
          end
          fnlsrc = _681_0
        end
        return on_values({string.format("%s:%s", src, (fnlsrc or line))})
      elseif (_676_0 == nil) then
        return on_error("Repl", "Unknown value")
      else
        local _ = _676_0
        return on_error("Repl", "No source info")
      end
    end
    return run_command(read, on_error, _675_)
  end
  do end (compiler.metadata):set(commands.find, "fnl/docstring", "Print the filename and line number for a given function")
  commands.doc = function(env, read, on_values, on_error, scope)
    local function _686_(_241)
      local name = tostring(_241)
      local path = (utils["multi-sym?"](name) or {name})
      local ok_3f, target = nil, nil
      local function _687_()
        return (utils["get-in"](scope.specials, path) or utils["get-in"](scope.macros, path) or resolve(name, env, scope))
      end
      ok_3f, target = pcall(_687_)
      if ok_3f then
        return on_values({specials.doc(target, name)})
      else
        return on_error("Repl", ("Could not find " .. name .. " for docs."))
      end
    end
    return run_command(read, on_error, _686_)
  end
  do end (compiler.metadata):set(commands.doc, "fnl/docstring", "Print the docstring and arglist for a function, macro, or special form.")
  commands.compile = function(env, read, on_values, on_error, scope)
    local function _689_(_241)
      local allowedGlobals = specials["current-global-names"](env)
      local ok_3f, result = pcall(compiler.compile, _241, {allowedGlobals = allowedGlobals, env = env, scope = scope})
      if ok_3f then
        return on_values({result})
      else
        return on_error("Repl", ("Error compiling expression: " .. result))
      end
    end
    return run_command(read, on_error, _689_)
  end
  do end (compiler.metadata):set(commands.compile, "fnl/docstring", "compiles the expression into lua and prints the result.")
  local function load_plugin_commands(plugins)
    for _, plugin in ipairs((plugins or {})) do
      for name, f in pairs(plugin) do
        local _691_0 = name:match("^repl%-command%-(.*)")
        if (nil ~= _691_0) then
          local cmd_name = _691_0
          commands[cmd_name] = (commands[cmd_name] or f)
        end
      end
    end
    return nil
  end
  local function run_command_loop(input, read, loop, env, on_values, on_error, scope, chars)
    local command_name = input:match(",([^%s/]+)")
    do
      local _693_0 = commands[command_name]
      if (nil ~= _693_0) then
        local command = _693_0
        command(env, read, on_values, on_error, scope, chars)
      else
        local _ = _693_0
        if ("exit" ~= command_name) then
          on_values({"Unknown command", command_name})
        end
      end
    end
    if ("exit" ~= command_name) then
      return loop()
    end
  end
  local function try_readline_21(opts, ok, readline)
    if ok then
      if readline.set_readline_name then
        readline.set_readline_name("fennel")
      end
      readline.set_options({histfile = "", keeplines = 1000})
      opts.readChunk = function(parser_state)
        local prompt = nil
        if (0 < parser_state["stack-size"]) then
          prompt = ".. "
        else
          prompt = ">> "
        end
        local str = readline.readline(prompt)
        if str then
          return (str .. "\n")
        end
      end
      local completer0 = nil
      opts.registerCompleter = function(repl_completer)
        completer0 = repl_completer
        return nil
      end
      local function repl_completer(text, from, to)
        if completer0 then
          readline.set_completion_append_character("")
          return completer0(text:sub(from, to))
        else
          return {}
        end
      end
      readline.set_complete_function(repl_completer)
      return readline
    end
  end
  local function should_use_readline_3f(opts)
    return (("dumb" ~= os.getenv("TERM")) and not opts.readChunk and not opts.registerCompleter)
  end
  local function repl(_3foptions)
    local old_root_options = utils.root.options
    local _702_ = utils.copy(_3foptions)
    local opts = _702_
    local _3ffennelrc = _702_["fennelrc"]
    local _ = nil
    opts.fennelrc = nil
    _ = nil
    local readline = (should_use_readline_3f(opts) and try_readline_21(opts, pcall(require, "readline")))
    local _0 = nil
    if _3ffennelrc then
      _0 = _3ffennelrc()
    else
    _0 = nil
    end
    local env = specials["wrap-env"]((opts.env or rawget(_G, "_ENV") or _G))
    local callbacks = {env = env, onError = (opts.onError or default_on_error), onValues = (opts.onValues or default_on_values), pp = (opts.pp or view), readChunk = (opts.readChunk or default_read_chunk)}
    local save_locals_3f = (opts.saveLocals ~= false)
    local byte_stream, clear_stream = nil, nil
    local function _704_(_241)
      return callbacks.readChunk(_241)
    end
    byte_stream, clear_stream = parser.granulate(_704_)
    local chars = {}
    local read, reset = nil, nil
    local function _705_(parser_state)
      local b = byte_stream(parser_state)
      if b then
        table.insert(chars, string.char(b))
      end
      return b
    end
    read, reset = parser.parser(_705_)
    env.___repl___ = callbacks
    opts.env, opts.scope = env, compiler["make-scope"]()
    opts.useMetadata = (opts.useMetadata ~= false)
    if (opts.allowedGlobals == nil) then
      opts.allowedGlobals = specials["current-global-names"](env)
    end
    if opts.registerCompleter then
      local function _709_()
        local _708_0 = opts.scope
        local function _710_(...)
          return completer(env, _708_0, ...)
        end
        return _710_
      end
      opts.registerCompleter(_709_())
    end
    load_plugin_commands(opts.plugins)
    if save_locals_3f then
      local function newindex(t, k, v)
        if opts.scope.manglings[k] then
          return rawset(t, k, v)
        end
      end
      env.___replLocals___ = setmetatable({}, {__newindex = newindex})
    end
    local function print_values(...)
      local vals = {...}
      local out = {}
      local pp = callbacks.pp
      env._, env.__ = vals[1], vals
      for i = 1, select("#", ...) do
        table.insert(out, pp(vals[i]))
      end
      return callbacks.onValues(out)
    end
    local function loop()
      for k in pairs(chars) do
        chars[k] = nil
      end
      reset()
      local ok, parser_not_eof_3f, x = pcall(read)
      local src_string = table.concat(chars)
      local readline_not_eof_3f = (not readline or (src_string ~= "(null)"))
      local not_eof_3f = (readline_not_eof_3f and parser_not_eof_3f)
      if not ok then
        callbacks.onError("Parse", not_eof_3f)
        clear_stream()
        return loop()
      elseif command_3f(src_string) then
        return run_command_loop(src_string, read, loop, env, callbacks.onValues, callbacks.onError, opts.scope, chars)
      else
        if not_eof_3f then
          do
            local _714_0, _715_0 = nil, nil
            local function _716_()
              opts["source"] = src_string
              return opts
            end
            _714_0, _715_0 = pcall(compiler.compile, x, _716_())
            if ((_714_0 == false) and (nil ~= _715_0)) then
              local msg = _715_0
              clear_stream()
              callbacks.onError("Compile", msg)
            elseif ((_714_0 == true) and (nil ~= _715_0)) then
              local src = _715_0
              local src0 = nil
              if save_locals_3f then
                src0 = splice_save_locals(env, src, opts.scope)
              else
                src0 = src
              end
              local _718_0, _719_0 = pcall(specials["load-code"], src0, env)
              if ((_718_0 == false) and (nil ~= _719_0)) then
                local msg = _719_0
                clear_stream()
                callbacks.onError("Lua Compile", msg, src0)
              elseif (true and (nil ~= _719_0)) then
                local _1 = _718_0
                local chunk = _719_0
                local function _720_()
                  return print_values(chunk())
                end
                local function _721_(...)
                  return callbacks.onError("Runtime", ...)
                end
                xpcall(_720_, _721_)
              end
            end
          end
          utils.root.options = old_root_options
          return loop()
        end
      end
    end
    loop()
    if readline then
      return readline.save_history()
    end
  end
  return repl
end
package.preload["fennel.specials"] = package.preload["fennel.specials"] or function(...)
  local utils = require("fennel.utils")
  local view = require("fennel.view")
  local parser = require("fennel.parser")
  local compiler = require("fennel.compiler")
  local unpack = (table.unpack or _G.unpack)
  local SPECIALS = compiler.scopes.global.specials
  local function wrap_env(env)
    local function _415_(_, key)
      if utils["string?"](key) then
        return env[compiler["global-unmangling"](key)]
      else
        return env[key]
      end
    end
    local function _417_(_, key, value)
      if utils["string?"](key) then
        env[compiler["global-unmangling"](key)] = value
        return nil
      else
        env[key] = value
        return nil
      end
    end
    local function _419_()
      local function putenv(k, v)
        local _420_
        if utils["string?"](k) then
          _420_ = compiler["global-unmangling"](k)
        else
          _420_ = k
        end
        return _420_, v
      end
      return next, utils.kvmap(env, putenv), nil
    end
    return setmetatable({}, {__index = _415_, __newindex = _417_, __pairs = _419_})
  end
  local function current_global_names(_3fenv)
    local mt = nil
    do
      local _422_0 = getmetatable(_3fenv)
      if ((_G.type(_422_0) == "table") and (nil ~= _422_0.__pairs)) then
        local mtpairs = _422_0.__pairs
        local tbl_14_ = {}
        for k, v in mtpairs(_3fenv) do
          local k_15_, v_16_ = k, v
          if ((k_15_ ~= nil) and (v_16_ ~= nil)) then
            tbl_14_[k_15_] = v_16_
          end
        end
        mt = tbl_14_
      elseif (_422_0 == nil) then
        mt = (_3fenv or _G)
      else
      mt = nil
      end
    end
    return (mt and utils.kvmap(mt, compiler["global-unmangling"]))
  end
  local function load_code(code, _3fenv, _3ffilename)
    local env = (_3fenv or rawget(_G, "_ENV") or _G)
    local _425_0, _426_0 = rawget(_G, "setfenv"), rawget(_G, "loadstring")
    if ((nil ~= _425_0) and (nil ~= _426_0)) then
      local setfenv = _425_0
      local loadstring = _426_0
      local f = assert(loadstring(code, _3ffilename))
      setfenv(f, env)
      return f
    else
      local _ = _425_0
      return assert(load(code, _3ffilename, "t", env))
    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  ")
      local mt = getmetatable(tgt)
      if ((type(tgt) == "function") or ((type(mt) == "table") and (type(mt.__call) == "function"))) then
        local arglist = table.concat(((compiler.metadata):get(tgt, "fnl/arglist") or {"#<unknown-arguments>"}), " ")
        local _428_
        if (0 < #arglist) then
          _428_ = " "
        else
          _428_ = ""
        end
        return string.format("(%s%s%s)\n  %s", name, _428_, arglist, docstring)
      else
        return string.format("%s\n  %s", name, docstring)
      end
    end
  end
  local function doc_special(name, arglist, docstring, body_form_3f)
    compiler.metadata[SPECIALS[name]] = {["fnl/arglist"] = arglist, ["fnl/body-form?"] = body_form_3f, ["fnl/docstring"] = docstring}
    return nil
  end
  local function compile_do(ast, scope, parent, _3fstart)
    local start = (_3fstart or 2)
    local len = #ast
    local sub_scope = compiler["make-scope"](scope)
    for i = start, len do
      compiler.compile1(ast[i], sub_scope, parent, {nval = 0})
    end
    return nil
  end
  SPECIALS["do"] = function(ast, scope, parent, opts, _3fstart, _3fchunk, _3fsub_scope, _3fpre_syms)
    local start = (_3fstart or 2)
    local sub_scope = (_3fsub_scope or compiler["make-scope"](scope))
    local chunk = (_3fchunk or {})
    local len = #ast
    local retexprs = {returned = true}
    local function compile_body(outer_target, outer_tail, outer_retexprs)
      if (len < start) then
        compiler.compile1(nil, sub_scope, chunk, {tail = outer_tail, target = outer_target})
      else
        for i = start, 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_scope, chunk, subopts)
          if (i ~= len) then
            compiler["keep-side-effects"](subexprs, parent, nil, ast[i])
          end
        end
      end
      compiler.emit(parent, chunk, ast)
      compiler.emit(parent, "end", ast)
      utils.hook("do", ast, sub_scope)
      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 = ((_3fpre_syms and _3fpre_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
      compiler.emit(parent, string.format("local function %s(%s)", fname, fargs), ast)
      return compile_body(nil, true, utils.expr((fname .. "(" .. fargs .. ")"), "statement"))
    end
  end
  doc_special("do", {"..."}, "Evaluate multiple forms; return last value.", true)
  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
    end
    return exprs
  end
  doc_special("values", {"..."}, "Return multiple values from a function. Must be in tail position.")
  local function __3estack(stack, tbl)
    for k, v in pairs(tbl) do
      table.insert(stack, k)
      table.insert(stack, v)
    end
    return stack
  end
  local function literal_3f(val)
    local res = true
    if utils["list?"](val) then
      res = false
    elseif utils["table?"](val) then
      local stack = __3estack({}, val)
      for _, elt in ipairs(stack) do
        if not res then break end
        if utils["list?"](elt) then
          res = false
        elseif utils["table?"](elt) then
          __3estack(stack, elt)
        end
      end
    end
    return res
  end
  local function compile_value(v)
    local opts = {nval = 1, tail = false}
    local scope = compiler["make-scope"]()
    local chunk = {}
    local _439_ = compiler.compile1(v, scope, chunk, opts)
    local _440_ = _439_[1]
    local v0 = _440_[1]
    return v0
  end
  local function insert_meta(meta, k, v)
    local view_opts = {["escape-newlines?"] = true, ["line-length"] = math.huge, ["one-line?"] = true}
    compiler.assert((type(k) == "string"), ("expected string keys in metadata table, got: %s"):format(view(k, view_opts)))
    compiler.assert(literal_3f(v), ("expected literal value in metadata table, got: %s %s"):format(view(k, view_opts), view(v, view_opts)))
    table.insert(meta, view(k))
    local function _441_()
      if ("string" == type(v)) then
        return view(v, view_opts)
      else
        return compile_value(v)
      end
    end
    table.insert(meta, _441_())
    return meta
  end
  local function insert_arglist(meta, arg_list)
    local view_opts = {["escape-newlines?"] = true, ["line-length"] = math.huge, ["one-line?"] = true}
    table.insert(meta, "\"fnl/arglist\"")
    local function _442_(_241)
      return view(view(_241, view_opts))
    end
    table.insert(meta, ("{" .. table.concat(utils.map(arg_list, _442_), ", ") .. "}"))
    return meta
  end
  local function set_fn_metadata(f_metadata, parent, fn_name)
    if utils.root.options.useMetadata then
      local meta_fields = {}
      for k, v in utils.stablepairs(f_metadata) do
        if (k == "fnl/arglist") then
          insert_arglist(meta_fields, v)
        else
          insert_meta(meta_fields, k, v)
        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 _445_
      if not multi then
        _445_ = compiler["declare-local"](fn_name, {}, scope, ast)
      else
        _445_ = compiler["symbol-to-expression"](fn_name, scope)[1]
      end
      return _445_, not multi, 3
    else
      return nil, true, 2
    end
  end
  local function compile_named_fn(ast, f_scope, f_chunk, parent, index, fn_name, local_3f, arg_name_list, f_metadata)
    for i = (index + 1), #ast do
      compiler.compile1(ast[i], f_scope, f_chunk, {nval = (((i ~= #ast) and 0) or nil), tail = (i == #ast)})
    end
    local _448_
    if local_3f then
      _448_ = "local function %s(%s)"
    else
      _448_ = "%s = function(%s)"
    end
    compiler.emit(parent, string.format(_448_, fn_name, table.concat(arg_name_list, ", ")), ast)
    compiler.emit(parent, f_chunk, ast)
    compiler.emit(parent, "end", ast)
    set_fn_metadata(f_metadata, parent, fn_name)
    utils.hook("fn", ast, f_scope)
    return utils.expr(fn_name, "sym")
  end
  local function compile_anonymous_fn(ast, f_scope, f_chunk, parent, index, arg_name_list, f_metadata, scope)
    local fn_name = compiler.gensym(scope)
    return compile_named_fn(ast, f_scope, f_chunk, parent, index, fn_name, true, arg_name_list, f_metadata)
  end
  local function maybe_metadata(ast, pred, handler, mt, index)
    local index_2a = (index + 1)
    local index_2a_before_ast_end_3f = (index_2a < #ast)
    local expr = ast[index_2a]
    if (index_2a_before_ast_end_3f and pred(expr)) then
      return handler(mt, expr), index_2a
    else
      return mt, index
    end
  end
  local function get_function_metadata(ast, arg_list, index)
    local function _451_(_241, _242)
      local tbl_14_ = _241
      for k, v in pairs(_242) do
        local k_15_, v_16_ = k, v
        if ((k_15_ ~= nil) and (v_16_ ~= nil)) then
          tbl_14_[k_15_] = v_16_
        end
      end
      return tbl_14_
    end
    local function _453_(_241, _242)
      _241["fnl/docstring"] = _242
      return _241
    end
    return maybe_metadata(ast, utils["kv-table?"], _451_, maybe_metadata(ast, utils["string?"], _453_, {["fnl/arglist"] = arg_list}, index))
  end
  SPECIALS.fn = function(ast, scope, parent)
    local f_scope = nil
    do
      local _454_0 = compiler["make-scope"](scope)
      _454_0["vararg"] = false
      f_scope = _454_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_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 destructure_arg(arg)
      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, symtype = "arg"})
      return declared
    end
    local function destructure_amp(i)
      compiler.assert((i == (#arg_list - 1)), "expected rest argument before last parameter", arg_list[(i + 1)], arg_list)
      f_scope.vararg = true
      compiler.destructure(arg_list[#arg_list], {utils.varg()}, ast, f_scope, f_chunk, {declaration = true, nomulti = true, symtype = "arg"})
      return "..."
    end
    local function get_arg_name(arg, i)
      if f_scope.vararg then
        return nil
      elseif 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, "&") then
        return destructure_amp(i)
      elseif (utils["sym?"](arg) and (tostring(arg) ~= "nil") and not utils["multi-sym?"](tostring(arg))) then
        return compiler["declare-local"](arg, {}, f_scope, ast)
      elseif utils["table?"](arg) then
        return destructure_arg(arg)
      else
        return compiler.assert(false, ("expected symbol for function parameter: %s"):format(tostring(arg)), ast[index])
      end
    end
    local arg_name_list = nil
    do
      local tbl_17_ = {}
      local i_18_ = #tbl_17_
      for i, a in ipairs(arg_list) do
        local val_19_ = get_arg_name(a, i)
        if (nil ~= val_19_) then
          i_18_ = (i_18_ + 1)
          tbl_17_[i_18_] = val_19_
        end
      end
      arg_name_list = tbl_17_
    end
    local f_metadata, index0 = get_function_metadata(ast, arg_list, index)
    if fn_name then
      return compile_named_fn(ast, f_scope, f_chunk, parent, index0, fn_name, local_3f, arg_name_list, f_metadata)
    else
      return compile_anonymous_fn(ast, f_scope, f_chunk, parent, index0, arg_name_list, f_metadata, scope)
    end
  end
  doc_special("fn", {"name?", "args", "docstring?", "..."}, "Function syntax. May optionally include a name and docstring or a metadata table.\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.", true)
  SPECIALS.lua = function(ast, _, parent)
    compiler.assert(((#ast == 2) or (#ast == 3)), "expected 1 or 2 arguments", ast)
    local _459_
    do
      local _458_0 = utils["sym?"](ast[2])
      if (nil ~= _458_0) then
        _459_ = tostring(_458_0)
      else
        _459_ = _458_0
      end
    end
    if ("nil" ~= _459_) then
      table.insert(parent, {ast = ast, leaf = tostring(ast[2])})
    end
    local _463_
    do
      local _462_0 = utils["sym?"](ast[3])
      if (nil ~= _462_0) then
        _463_ = tostring(_462_0)
      else
        _463_ = _462_0
      end
    end
    if ("nil" ~= _463_) then
      return tostring(ast[3])
    end
  end
  local function dot(ast, scope, parent)
    compiler.assert((1 < #ast), "expected table argument", ast)
    local len = #ast
    local _466_ = compiler.compile1(ast[2], scope, parent, {nval = 1})
    local lhs = _466_[1]
    if (len == 2) then
      return tostring(lhs)
    else
      local indices = {}
      for i = 3, len do
        local index = ast[i]
        if (utils["string?"](index) and utils["valid-lua-identifier?"](index)) then
          table.insert(indices, ("." .. index))
        else
          local _467_ = compiler.compile1(index, scope, parent, {nval = 1})
          local index0 = _467_[1]
          table.insert(indices, ("[" .. tostring(index0) .. "]"))
        end
      end
      if (tostring(lhs):find("[{\"0-9]") 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, symtype = "global"})
    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, symtype = "set"})
    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, symtype = "set"})
    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, symtype = "local"})
    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, symtype = "var"})
    return nil
  end
  doc_special("var", {"name", "val"}, "Introduce new mutable local.")
  local function kv_3f(t)
    local _471_
    do
      local tbl_17_ = {}
      local i_18_ = #tbl_17_
      for k in pairs(t) do
        local val_19_ = nil
        if ("number" ~= type(k)) then
          val_19_ = k
        else
        val_19_ = nil
        end
        if (nil ~= val_19_) then
          i_18_ = (i_18_ + 1)
          tbl_17_[i_18_] = val_19_
        end
      end
      _471_ = tbl_17_
    end
    return _471_[1]
  end
  SPECIALS.let = function(ast, scope, parent, opts)
    local bindings = ast[2]
    local pre_syms = {}
    compiler.assert((utils["table?"](bindings) and not kv_3f(bindings)), "expected binding sequence", bindings)
    compiler.assert(((#bindings % 2) == 0), "expected even number of name/value bindings", ast[2])
    compiler.assert((3 <= #ast), "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, symtype = "let"})
    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.", true)
  local function get_prev_line(parent)
    if ("table" == type(parent)) then
      return get_prev_line((parent.leaf or parent[#parent]))
    else
      return (parent or "")
    end
  end
  local function disambiguate_3f(rootstr, parent)
    local function _476_()
      local _475_0 = get_prev_line(parent)
      if (nil ~= _475_0) then
        local prev_line = _475_0
        return prev_line:match("%)$")
      end
    end
    return (rootstr:match("^{") or rootstr:match("^%(") or _476_())
  end
  SPECIALS.tset = function(ast, scope, parent)
    compiler.assert((3 < #ast), "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 _478_ = compiler.compile1(ast[i], scope, parent, {nval = 1})
      local key = _478_[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 disambiguate_3f(rootstr, parent) then
      fmtstr = "do end (%s)[%s] = %s"
    else
      fmtstr = "%s[%s] = %s"
    end
    return compiler.emit(parent, fmtstr:format(rootstr, 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)
    compiler.assert((2 < #ast), "expected condition and body", ast)
    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
    if (1 == (#ast % 2)) then
      table.insert(ast, utils.sym("nil"))
    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 else_branch = 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 = fstr:format(cond)
      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
        compiler.emit(last_buffer, "else", ast)
        compiler.emit(last_buffer, else_branch.chunk, ast)
        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.")
  local function remove_until_condition(bindings)
    local last_item = bindings[(#bindings - 1)]
    if ((utils["sym?"](last_item) and (tostring(last_item) == "&until")) or ("until" == last_item)) then
      table.remove(bindings, (#bindings - 1))
      return table.remove(bindings)
    end
  end
  local function compile_until(condition, scope, chunk)
    if condition then
      local _487_ = compiler.compile1(condition, scope, chunk, {nval = 1})
      local condition_lua = _487_[1]
      return compiler.emit(chunk, ("if %s then break end"):format(tostring(condition_lua)), utils.expr(condition, "expression"))
    end
  end
  SPECIALS.each = function(ast, scope, parent)
    compiler.assert((3 <= #ast), "expected body expression", ast[1])
    compiler.assert(utils["table?"](ast[2]), "expected binding table", ast)
    compiler.assert((2 <= #ast[2]), "expected binding and iterator", ast)
    local binding = setmetatable(utils.copy(ast[2]), getmetatable(ast[2]))
    local until_condition = remove_until_condition(binding)
    local iter = table.remove(binding, #binding)
    local destructures = {}
    local new_manglings = {}
    local sub_scope = compiler["make-scope"](scope)
    local function destructure_binding(v)
      compiler.assert(not utils["string?"](v), ("unexpected iterator clause " .. tostring(v)), binding)
      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, 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, symtype = "each"})
    end
    compiler["apply-manglings"](sub_scope, new_manglings, ast)
    compile_until(until_condition, sub_scope, chunk)
    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.", true)
  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.", true)
  local function for_2a(ast, scope, parent)
    compiler.assert(utils["table?"](ast[2]), "expected binding table", ast)
    local ranges = setmetatable(utils.copy(ast[2]), getmetatable(ast[2]))
    local until_condition = remove_until_condition(ranges)
    local binding_sym = table.remove(ranges, 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((3 <= #ast), "expected body expression", ast[1])
    compiler.assert((#ranges <= 3), "unexpected arguments", ranges)
    compiler.assert((1 < #ranges), "expected range to include start and stop", ranges)
    for i = 1, math.min(#ranges, 3) do
      range_args[i] = tostring(compiler.compile1(ranges[i], 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_until(until_condition, sub_scope, chunk)
    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).", true)
  local function native_method_call(ast, _scope, _parent, target, args)
    local _491_ = ast
    local _ = _491_[1]
    local _0 = _491_[2]
    local method_string = _491_[3]
    local call_string = nil
    if ((target.type == "literal") or (target.type == "varg") 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 _493_ = compiler.compile1(ast[2], scope, parent, {nval = 1})
    local target = _493_[1]
    local args = {}
    for i = 4, #ast do
      local subexprs = nil
      local _494_
      if (i ~= #ast) then
        _494_ = 1
      else
      _494_ = nil
      end
      subexprs = compiler.compile1(ast[i], scope, parent, {nval = _494_})
      utils.map(subexprs, tostring, args)
    end
    if (utils["string?"](ast[3]) 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 c = nil
    local _497_
    do
      local tbl_17_ = {}
      local i_18_ = #tbl_17_
      for i, elt in ipairs(ast) do
        local val_19_ = nil
        if (i ~= 1) then
          val_19_ = view(ast[i], {["one-line?"] = true})
        else
        val_19_ = nil
        end
        if (nil ~= val_19_) then
          i_18_ = (i_18_ + 1)
          tbl_17_[i_18_] = val_19_
        end
      end
      _497_ = tbl_17_
    end
    c = table.concat(_497_, " "):gsub("%]%]", "]\\]")
    return compiler.emit(parent, ("--[[ " .. c .. " ]]"), ast)
  end
  doc_special("comment", {"..."}, "Comment which will be emitted in Lua output.", true)
  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 _502_0 = compiler["make-scope"](scope)
      _502_0["vararg"] = false
      _502_0["hashfn"] = true
      f_scope = _502_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, _3fparent_node)
      if utils["sym?"](node, "$...") then
        f_scope.vararg = true
        if _3fparent_node then
          _3fparent_node[idx] = utils.varg()
          return nil
        else
          return utils.varg()
        end
      else
        return ((utils["list?"](node) and (not _3fparent_node or not utils["sym?"](node[1], "hashfn"))) or utils["table?"](node))
      end
    end
    utils["walk-tree"](ast, 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 = tostring(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 maybe_short_circuit_protect(ast, i, name, _507_0)
    local _508_ = _507_0
    local mac = _508_["macros"]
    local call = (utils["list?"](ast) and tostring(ast[1]))
    if ((("or" == name) or ("and" == name)) and (1 < i) and (mac[call] or ("set" == call) or ("tset" == call) or ("global" == call))) then
      return utils.list(utils.sym("do"), ast)
    else
      return ast
    end
  end
  local function arithmetic_special(name, zero_arity, unary_prefix, ast, scope, parent)
    local len = #ast
    local operands = {}
    local padded_op = (" " .. name .. " ")
    for i = 2, len do
      local subast = maybe_short_circuit_protect(ast[i], i, name, scope)
      local subexprs = compiler.compile1(subast, scope, parent)
      if (i == len) then
        utils.map(subexprs, tostring, operands)
      else
        table.insert(operands, tostring(subexprs[1]))
      end
    end
    local _511_0 = #operands
    if (_511_0 == 0) then
      local _512_
      do
        compiler.assert(zero_arity, "Expected more than 0 arguments", ast)
        _512_ = zero_arity
      end
      return utils.expr(_512_, "literal")
    elseif (_511_0 == 1) then
      if utils["varg?"](ast[2]) then
        return compiler.assert(false, "tried to use vararg with operator", ast)
      elseif unary_prefix then
        return ("(" .. unary_prefix .. padded_op .. operands[1] .. ")")
      else
        return operands[1]
      end
    else
      local _ = _511_0
      return ("(" .. table.concat(operands, padded_op) .. ")")
    end
  end
  local function define_arithmetic_special(name, zero_arity, unary_prefix, _3flua_name)
    local _516_
    do
      local _515_0 = (_3flua_name or name)
      local function _517_(...)
        return arithmetic_special(_515_0, zero_arity, unary_prefix, ...)
      end
      _516_ = _517_
    end
    SPECIALS[name] = _516_
    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")
  SPECIALS["or"] = function(ast, scope, parent)
    return arithmetic_special("or", "false", nil, ast, scope, parent)
  end
  SPECIALS["and"] = function(ast, scope, parent)
    return arithmetic_special("and", "true", nil, ast, scope, parent)
  end
  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.")
  local function bitop_special(native_name, lib_name, zero_arity, unary_prefix, ast, scope, parent)
    if (#ast == 1) then
      return compiler.assert(zero_arity, "Expected more than 0 arguments.", ast)
    else
      local len = #ast
      local operands = {}
      local padded_native_name = (" " .. native_name .. " ")
      local prefixed_lib_name = ("bit." .. lib_name)
      for i = 2, len do
        local subexprs = nil
        local _518_
        if (i ~= len) then
          _518_ = 1
        else
        _518_ = nil
        end
        subexprs = compiler.compile1(ast[i], scope, parent, {nval = _518_})
        utils.map(subexprs, tostring, operands)
      end
      if (#operands == 1) then
        if utils.root.options.useBitLib then
          return (prefixed_lib_name .. "(" .. unary_prefix .. ", " .. operands[1] .. ")")
        else
          return ("(" .. unary_prefix .. padded_native_name .. operands[1] .. ")")
        end
      else
        if utils.root.options.useBitLib then
          return (prefixed_lib_name .. "(" .. table.concat(operands, ", ") .. ")")
        else
          return ("(" .. table.concat(operands, padded_native_name) .. ")")
        end
      end
    end
  end
  local function define_bitop_special(name, zero_arity, unary_prefix, native)
    local function _524_(...)
      return bitop_special(native, name, zero_arity, unary_prefix, ...)
    end
    SPECIALS[name] = _524_
    return nil
  end
  define_bitop_special("lshift", nil, "1", "<<")
  define_bitop_special("rshift", nil, "1", ">>")
  define_bitop_special("band", "0", "0", "&")
  define_bitop_special("bor", "0", "0", "|")
  define_bitop_special("bxor", "0", "0", "~")
  doc_special("lshift", {"x", "n"}, "Bitwise logical left shift of x by n bits.\nOnly works in Lua 5.3+ or LuaJIT with the --use-bit-lib flag.")
  doc_special("rshift", {"x", "n"}, "Bitwise logical right shift of x by n bits.\nOnly works in Lua 5.3+ or LuaJIT with the --use-bit-lib flag.")
  doc_special("band", {"x1", "x2", "..."}, "Bitwise AND of any number of arguments.\nOnly works in Lua 5.3+ or LuaJIT with the --use-bit-lib flag.")
  doc_special("bor", {"x1", "x2", "..."}, "Bitwise OR of any number of arguments.\nOnly works in Lua 5.3+ or LuaJIT with the --use-bit-lib flag.")
  doc_special("bxor", {"x1", "x2", "..."}, "Bitwise XOR of any number of arguments.\nOnly works in Lua 5.3+ or LuaJIT with the --use-bit-lib flag.")
  SPECIALS.bnot = function(ast, scope, parent)
    compiler.assert((#ast == 2), "expected one argument", ast)
    local _525_ = compiler.compile1(ast[2], scope, parent, {nval = 1})
    local value = _525_[1]
    if utils.root.options.useBitLib then
      return ("bit.bnot(" .. tostring(value) .. ")")
    else
      return ("~(" .. tostring(value) .. ")")
    end
  end
  doc_special("bnot", {"x"}, "Bitwise negation; only works in Lua 5.3+ or LuaJIT with the --use-bit-lib flag.")
  doc_special("..", {"a", "b", "..."}, "String concatenation operator; works the same as Lua but accepts more arguments.")
  local function native_comparator(op, _527_0, scope, parent)
    local _528_ = _527_0
    local _ = _528_[1]
    local lhs_ast = _528_[2]
    local rhs_ast = _528_[3]
    local _529_ = compiler.compile1(lhs_ast, scope, parent, {nval = 1})
    local lhs = _529_[1]
    local _530_ = compiler.compile1(rhs_ast, scope, parent, {nval = 1})
    local rhs = _530_[1]
    return string.format("(%s %s %s)", tostring(lhs), op, tostring(rhs))
  end
  local function idempotent_comparator(op, chain_op, ast, scope, parent)
    local vals = nil
    do
      local tbl_17_ = {}
      local i_18_ = #tbl_17_
      for i = 2, #ast do
        local val_19_ = tostring(compiler.compile1(ast[i], scope, parent, {nval = 1})[1])
        if (nil ~= val_19_) then
          i_18_ = (i_18_ + 1)
          tbl_17_[i_18_] = val_19_
        end
      end
      vals = tbl_17_
    end
    local comparisons = nil
    do
      local tbl_17_ = {}
      local i_18_ = #tbl_17_
      for i = 1, (#vals - 1) do
        local val_19_ = string.format("(%s %s %s)", vals[i], op, vals[(i + 1)])
        if (nil ~= val_19_) then
          i_18_ = (i_18_ + 1)
          tbl_17_[i_18_] = val_19_
        end
      end
      comparisons = tbl_17_
    end
    local chain = string.format(" %s ", (chain_op or "and"))
    return ("(" .. table.concat(comparisons, chain) .. ")")
  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
    do
      local tbl_17_ = comparisons
      local i_18_ = #tbl_17_
      for i = 1, (#arglist - 1) do
        local val_19_ = string.format("(%s %s %s)", arglist[i], op, arglist[(i + 1)])
        if (nil ~= val_19_) then
          i_18_ = (i_18_ + 1)
          tbl_17_[i_18_] = val_19_
        end
      end
    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, _3flua_op, _3fchain_op)
    do
      local op = (_3flua_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)
        elseif utils["every?"]({unpack(ast, 2)}, utils["idempotent-expr?"]) then
          return idempotent_comparator(op, _3fchain_op, ast, scope, parent)
        else
          return double_eval_protected_comparator(op, _3fchain_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")
  local function define_unary_special(op, _3frealop)
    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 ((_3frealop 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("length", "#")
  doc_special("length", {"x"}, "Returns the length of a table or string.")
  SPECIALS["~="] = SPECIALS["not="]
  SPECIALS["#"] = SPECIALS.length
  SPECIALS.quote = function(ast, scope, parent)
    compiler.assert((#ast == 2), "expected one argument", ast)
    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 macro_loaded = {}
  local function safe_getmetatable(tbl)
    local mt = getmetatable(tbl)
    assert((mt ~= getmetatable("")), "Illegal metatable access!")
    return mt
  end
  local safe_require = nil
  local function safe_compiler_env()
    local _537_
    do
      local _536_0 = rawget(_G, "utf8")
      if (nil ~= _536_0) then
        _537_ = utils.copy(_536_0)
      else
        _537_ = _536_0
      end
    end
    return {_VERSION = _VERSION, assert = assert, bit = rawget(_G, "bit"), error = error, getmetatable = safe_getmetatable, ipairs = ipairs, math = utils.copy(math), next = next, pairs = utils.stablepairs, pcall = pcall, print = print, rawequal = rawequal, rawget = rawget, rawlen = rawget(_G, "rawlen"), rawset = rawset, require = safe_require, select = select, setmetatable = setmetatable, string = utils.copy(string), table = utils.copy(table), tonumber = tonumber, tostring = tostring, type = type, utf8 = _537_, xpcall = xpcall}
  end
  local function combined_mt_pairs(env)
    local combined = {}
    local _539_ = getmetatable(env)
    local __index = _539_["__index"]
    if ("table" == type(__index)) then
      for k, v in pairs(__index) do
        combined[k] = v
      end
    end
    for k, v in next, env, nil do
      combined[k] = v
    end
    return next, combined, nil
  end
  local function make_compiler_env(ast, scope, parent, _3fopts)
    local provided = nil
    do
      local _541_0 = (_3fopts or utils.root.options)
      if ((_G.type(_541_0) == "table") and (_541_0["compiler-env"] == "strict")) then
        provided = safe_compiler_env()
      elseif ((_G.type(_541_0) == "table") and (nil ~= _541_0.compilerEnv)) then
        local compilerEnv = _541_0.compilerEnv
        provided = compilerEnv
      elseif ((_G.type(_541_0) == "table") and (nil ~= _541_0["compiler-env"])) then
        local compiler_env = _541_0["compiler-env"]
        provided = compiler_env
      else
        local _ = _541_0
        provided = safe_compiler_env(false)
      end
    end
    local env = nil
    local function _543_()
      return compiler.scopes.macro
    end
    local function _544_(symbol)
      compiler.assert(compiler.scopes.macro, "must call from macro", ast)
      return compiler.scopes.macro.manglings[tostring(symbol)]
    end
    local function _545_(base)
      return utils.sym(compiler.gensym((compiler.scopes.macro or scope), base))
    end
    local function _546_(form)
      compiler.assert(compiler.scopes.macro, "must call from macro", ast)
      return compiler.macroexpand(form, compiler.scopes.macro)
    end
    env = {["assert-compile"] = compiler.assert, ["ast-source"] = utils["ast-source"], ["comment?"] = utils["comment?"], ["get-scope"] = _543_, ["in-scope?"] = _544_, ["list?"] = utils["list?"], ["macro-loaded"] = macro_loaded, ["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(), comment = utils.comment, gensym = _545_, list = utils.list, macroexpand = _546_, metadata = compiler.metadata, sequence = utils.sequence, sym = utils.sym, unpack = unpack, version = utils.version, view = view}
    env._G = env
    return setmetatable(env, {__index = provided, __newindex = provided, __pairs = combined_mt_pairs})
  end
  local function _547_(...)
    local tbl_17_ = {}
    local i_18_ = #tbl_17_
    for c in string.gmatch((package.config or ""), "([^\n]+)") do
      local val_19_ = c
      if (nil ~= val_19_) then
        i_18_ = (i_18_ + 1)
        tbl_17_[i_18_] = val_19_
      end
    end
    return tbl_17_
  end
  local _549_ = _547_(...)
  local dirsep = _549_[1]
  local pathsep = _549_[2]
  local pathmark = _549_[3]
  local pkg_config = {dirsep = (dirsep or "/"), pathmark = (pathmark or "?"), pathsep = (pathsep or ";")}
  local function escapepat(str)
    return string.gsub(str, "[^%w]", "%%%1")
  end
  local function search_module(modulename, _3fpathstring)
    local pathsepesc = escapepat(pkg_config.pathsep)
    local pattern = ("([^%s]*)%s"):format(pathsepesc, pathsepesc)
    local no_dot_module = modulename:gsub("%.", pkg_config.dirsep)
    local fullpath = ((_3fpathstring 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 _550_0 = (io.open(filename) or io.open(filename2))
      if (nil ~= _550_0) then
        local file = _550_0
        file:close()
        return filename
      else
        local _ = _550_0
        return nil, ("no file '" .. filename .. "'")
      end
    end
    local function find_in_path(start, _3ftried_paths)
      local _552_0 = fullpath:match(pattern, start)
      if (nil ~= _552_0) then
        local path = _552_0
        local _553_0, _554_0 = try_path(path)
        if (nil ~= _553_0) then
          local filename = _553_0
          return filename
        elseif ((_553_0 == nil) and (nil ~= _554_0)) then
          local error = _554_0
          local function _556_()
            local _555_0 = (_3ftried_paths or {})
            table.insert(_555_0, error)
            return _555_0
          end
          return find_in_path((start + #path + 1), _556_())
        end
      else
        local _ = _552_0
        local function _558_()
          local tried_paths = table.concat((_3ftried_paths or {}), "\n\9")
          if (_VERSION < "Lua 5.4") then
            return ("\n\9" .. tried_paths)
          else
            return tried_paths
          end
        end
        return nil, _558_()
      end
    end
    return find_in_path(1)
  end
  local function make_searcher(_3foptions)
    local function _561_(module_name)
      local opts = utils.copy(utils.root.options)
      for k, v in pairs((_3foptions or {})) do
        opts[k] = v
      end
      opts["module-name"] = module_name
      local _562_0, _563_0 = search_module(module_name)
      if (nil ~= _562_0) then
        local filename = _562_0
        local function _564_(...)
          return utils["fennel-module"].dofile(filename, opts, ...)
        end
        return _564_, filename
      elseif ((_562_0 == nil) and (nil ~= _563_0)) then
        local error = _563_0
        return error
      end
    end
    return _561_
  end
  local function dofile_with_searcher(fennel_macro_searcher, filename, opts, ...)
    local searchers = (package.loaders or package.searchers or {})
    local _ = table.insert(searchers, 1, fennel_macro_searcher)
    local m = utils["fennel-module"].dofile(filename, opts, ...)
    table.remove(searchers, 1)
    return m
  end
  local function fennel_macro_searcher(module_name)
    local opts = nil
    do
      local _566_0 = utils.copy(utils.root.options)
      _566_0["module-name"] = module_name
      _566_0["env"] = "_COMPILER"
      _566_0["requireAsInclude"] = false
      _566_0["allowedGlobals"] = nil
      opts = _566_0
    end
    local _567_0 = search_module(module_name, utils["fennel-module"]["macro-path"])
    if (nil ~= _567_0) then
      local filename = _567_0
      local _568_
      if (opts["compiler-env"] == _G) then
        local function _569_(...)
          return dofile_with_searcher(fennel_macro_searcher, filename, opts, ...)
        end
        _568_ = _569_
      else
        local function _570_(...)
          return utils["fennel-module"].dofile(filename, opts, ...)
        end
        _568_ = _570_
      end
      return _568_, filename
    end
  end
  local function lua_macro_searcher(module_name)
    local _573_0 = search_module(module_name, package.path)
    if (nil ~= _573_0) then
      local filename = _573_0
      local code = nil
      do
        local f = io.open(filename)
        local function close_handlers_10_(ok_11_, ...)
          f:close()
          if ok_11_ then
            return ...
          else
            return error(..., 0)
          end
        end
        local function _575_()
          return assert(f:read("*a"))
        end
        code = close_handlers_10_(_G.xpcall(_575_, (package.loaded.fennel or debug).traceback))
      end
      local chunk = load_code(code, make_compiler_env(), filename)
      return chunk, filename
    end
  end
  local macro_searchers = {fennel_macro_searcher, lua_macro_searcher}
  local function search_macro_module(modname, n)
    local _577_0 = macro_searchers[n]
    if (nil ~= _577_0) then
      local f = _577_0
      local _578_0, _579_0 = f(modname)
      if ((nil ~= _578_0) and true) then
        local loader = _578_0
        local _3ffilename = _579_0
        return loader, _3ffilename
      else
        local _ = _578_0
        return search_macro_module(modname, (n + 1))
      end
    end
  end
  local function sandbox_fennel_module(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, view = view}
    end
  end
  local function _583_(modname)
    local function _584_()
      local loader, filename = search_macro_module(modname, 1)
      compiler.assert(loader, (modname .. " module not found."))
      macro_loaded[modname] = loader(modname, filename)
      return macro_loaded[modname]
    end
    return (macro_loaded[modname] or sandbox_fennel_module(modname) or _584_())
  end
  safe_require = _583_
  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)
      compiler["check-binding-valid"](utils.sym(k), scope, ast, {["macro?"] = true})
      scope.macros[k] = v
    end
    return nil
  end
  local function resolve_module_name(_585_0, _scope, _parent, opts)
    local _586_ = _585_0
    local second = _586_[2]
    local filename = _586_["filename"]
    local filename0 = (filename or (utils["table?"](second) and second.filename))
    local module_name = utils.root.options["module-name"]
    local modexpr = compiler.compile(second, opts)
    local modname_chunk = load_code(modexpr)
    return modname_chunk(module_name, filename0)
  end
  SPECIALS["require-macros"] = function(ast, scope, parent, _3freal_ast)
    compiler.assert((#ast == 2), "Expected one module name argument", (_3freal_ast or ast))
    local modname = resolve_module_name(ast, scope, parent, {})
    compiler.assert(utils["string?"](modname), "module name must compile to string", (_3freal_ast or ast))
    if not macro_loaded[modname] then
      local loader, filename = search_macro_module(modname, 1)
      compiler.assert(loader, (modname .. " module not found."), ast)
      macro_loaded[modname] = compiler.assert(utils["table?"](loader(modname, filename)), "expected macros to be table", (_3freal_ast or ast))
    end
    if ("import-macros" == tostring(ast[1])) then
      return macro_loaded[modname]
    else
      return add_macros(macro_loaded[modname], ast, scope, parent)
    end
  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_10_(ok_11_, ...)
        f:close()
        if ok_11_ then
          return ...
        else
          return error(..., 0)
        end
      end
      local function _592_()
        return assert(f:read("*all")):gsub("[\13\n]*$", "")
      end
      src = close_handlers_10_(_G.xpcall(_592_, (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 _, v in ipairs(temp_chunk) do
      table.insert(utils.root.chunk, 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 = nil
    do
      local _595_0, _596_0 = pcall(resolve_module_name, ast, scope, parent, opts)
      if ((_595_0 == true) and (nil ~= _596_0)) then
        local modname = _596_0
        modexpr = utils.expr(string.format("%q", modname), "literal")
      else
        local _ = _595_0
        modexpr = compiler.compile1(ast[2], scope, parent, {nval = 1})[1]
      end
    end
    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 oldmod = utils.root.options["module-name"]
      local _ = nil
      utils.root.options["module-name"] = mod
      _ = nil
      local res = nil
      local function _600_()
        local _599_0 = search_module(mod)
        if (nil ~= _599_0) then
          local fennel_path = _599_0
          return include_path(ast, opts, fennel_path, mod, true)
        else
          local _0 = _599_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
      res = ((utils["member?"](mod, (utils.root.options.skipInclude or {})) and opts.fallback(modexpr, true)) or include_circular_fallback(mod, modexpr, opts.fallback, ast) or utils.root.scope.includes[mod] or _600_())
      utils.root.options["module-name"] = oldmod
      return res
    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 = current_global_names(env)
    return assert(load_code(compiler.compile(ast, opts), wrap_env(env)))(opts["module-name"], ast.filename)
  end
  SPECIALS.macros = function(ast, scope, parent)
    compiler.assert((#ast == 2), "Expected one table argument", ast)
    local macro_tbl = eval_compiler_2a(ast[2], scope, parent)
    compiler.assert(utils["table?"](macro_tbl), "Expected one table argument", ast)
    return add_macros(macro_tbl, 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.", true)
  SPECIALS.unquote = function(ast)
    return compiler.assert(false, "tried to use unquote outside quote", ast)
  end
  doc_special("unquote", {"..."}, "Evaluate the argument even if it's in a quoted form.")
  return {["current-global-names"] = current_global_names, ["load-code"] = load_code, ["macro-loaded"] = macro_loaded, ["macro-searchers"] = macro_searchers, ["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 = (table.unpack or _G.unpack)
  local scopes = {}
  local function make_scope(_3fparent)
    local parent = (_3fparent or scopes.global)
    local _260_
    if parent then
      _260_ = ((parent.depth or 0) + 1)
    else
      _260_ = 0
    end
    return {["gensym-base"] = setmetatable({}, {__index = (parent and parent["gensym-base"])}), autogensyms = setmetatable({}, {__index = (parent and parent.autogensyms)}), depth = _260_, gensyms = setmetatable({}, {__index = (parent and parent.gensyms)}), hashfn = (parent and parent.hashfn), includes = setmetatable({}, {__index = (parent and parent.includes)}), macros = setmetatable({}, {__index = (parent and parent.macros)}), manglings = setmetatable({}, {__index = (parent and parent.manglings)}), parent = parent, refedglobals = {}, specials = setmetatable({}, {__index = (parent and parent.specials)}), symmeta = setmetatable({}, {__index = (parent and parent.symmeta)}), unmanglings = setmetatable({}, {__index = (parent and parent.unmanglings)}), vararg = (parent and parent.vararg)}
  end
  local function assert_msg(ast, msg)
    local ast_tbl = nil
    if ("table" == type(ast)) then
      ast_tbl = ast
    else
      ast_tbl = {}
    end
    local m = getmetatable(ast)
    local filename = ((m and m.filename) or ast_tbl.filename or "unknown")
    local line = ((m and m.line) or ast_tbl.line or "?")
    local col = ((m and m.col) or ast_tbl.col or "?")
    local target = tostring((utils["sym?"](ast_tbl[1]) or ast_tbl[1] or "()"))
    return string.format("%s:%s:%s Compile error in '%s': %s", filename, line, col, target, msg)
  end
  local function assert_compile(condition, msg, ast, _3ffallback_ast)
    if not condition then
      local _263_ = (utils.root.options or {})
      local error_pinpoint = _263_["error-pinpoint"]
      local source = _263_["source"]
      local unfriendly = _263_["unfriendly"]
      local ast0 = nil
      if next(utils["ast-source"](ast)) then
        ast0 = ast
      else
        ast0 = (_3ffallback_ast or {})