~technomancy/antifennel

6783c6cb5630d6ef516071763913cf4f8177f740 — Phil Hagelberg 2 months ago 5f5b89a main
Update fennel compiler itself.
1 files changed, 950 insertions(+), 449 deletions(-)

M fennel
M fennel => fennel +950 -449
@@ 53,7 53,7 @@ package.preload["fennel.binary"] = package.preload["fennel.binary"] or function(
    local fennel_loader = nil
    local _0_
    do
      _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)))"
      _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\\9module '%%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["compile-string"](fennel_loader)


@@ 135,246 135,9 @@ package.preload["fennel.binary"] = package.preload["fennel.binary"] or function(
    local modules = _0_["modules"]
    return compile_binary(write_c(filename, modules, options), executable_name, static_lua, lua_include_dir, libraries)
  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])
  local help = ("\nUsage: %s --compile-binary FILE OUT STATIC_LUA_LIB LUA_INCLUDE_DIR\n\nCompile a binary from your Fennel program.\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
package.preload["fennelview"] = package.preload["fennelview"] or function(...)
  local function view_quote(str)
    return ("\"" .. str:gsub("\"", "\\\"") .. "\"")
  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
    local long = {}
    for i = 0, 31 do
      local ch = string.char(i)
      if not short_control_char_escapes[ch] then
        short_control_char_escapes[ch] = ("\\" .. i)
        long[ch] = ("\\%03d"):format(i)
      end
    end
    long_control_char_escapes = long
  end
  local function escape(str)
    return str:gsub("\\", "\\\\"):gsub("(%c)%f[0-9]", long_control_char_escapes):gsub("%c", short_control_char_escapes)
  end
  local function sequence_key_3f(k, len)
    return ((type(k) == "number") and (1 <= k) and (k <= len) and (math.floor(k) == k))
  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 == "string") or (ta == "number"))) then
      return (a < b)
    else
      local dta = type_order[a]
      local dtb = type_order[b]
      if (dta and dtb) then
        return (dta < dtb)
      elseif dta then
        return true
      elseif dtb then
        return false
      elseif "else" then
        return (ta < tb)
      end
    end
  end
  local function get_sequence_length(t)
    local len = 1
    for i in ipairs(t) do
      len = i
    end
    return len
  end
  local function get_nonsequential_keys(t)
    local keys = {}
    local sequence_length = get_sequence_length(t)
    for k in pairs(t) do
      if not sequence_key_3f(k, sequence_length) then
        table.insert(keys, k)
      end
    end
    table.sort(keys, sort_keys)
    return keys, sequence_length
  end
  local function count_table_appearances(t, appearances)
    if (type(t) == "table") then
      if not appearances[t] then
        appearances[t] = 1
        for k, v in pairs(t) do
          count_table_appearances(k, appearances)
          count_table_appearances(v, appearances)
        end
      else
        appearances[t] = ((appearances[t] or 0) + 1)
      end
    end
    return appearances
  end
  local put_value = nil
  local function puts(self, ...)
    for _, v in ipairs({...}) do
      table.insert(self.buffer, v)
    end
    return nil
  end
  local function tabify(self)
    return puts(self, "\n", (self.indent):rep(self.level))
  end
  local function already_visited_3f(self, v)
    return (self.ids[v] ~= nil)
  end
  local function get_id(self, v)
    local id = self.ids[v]
    if not id then
      local tv = type(v)
      id = ((self["max-ids"][tv] or 0) + 1)
      self["max-ids"][tv] = id
      self.ids[v] = id
    end
    return tostring(id)
  end
  local function put_sequential_table(self, t, len)
    puts(self, "[")
    self.level = (self.level + 1)
    for i = 1, len do
      local _0_ = (1 + len)
      if ((1 < i) and (i < _0_)) then
        puts(self, " ")
      end
      put_value(self, t[i])
    end
    self.level = (self.level - 1)
    return puts(self, "]")
  end
  local function put_key(self, k)
    if ((type(k) == "string") and k:find("^[-%w?\\^_!$%&*+./@:|<=>]+$")) then
      return puts(self, ":", k)
    else
      return put_value(self, k)
    end
  end
  local function put_kv_table(self, t, ordered_keys)
    puts(self, "{")
    self.level = (self.level + 1)
    for i, k in ipairs(ordered_keys) do
      if (self["table-edges"] or (i ~= 1)) then
        tabify(self)
      end
      put_key(self, k)
      puts(self, " ")
      put_value(self, t[k])
    end
    for i, v in ipairs(t) do
      tabify(self)
      put_key(self, i)
      puts(self, " ")
      put_value(self, v)
    end
    self.level = (self.level - 1)
    if self["table-edges"] then
      tabify(self)
    end
    return puts(self, "}")
  end
  local function put_table(self, t)
    local metamethod = nil
    local function _1_()
      local _0_0 = t
      if _0_0 then
        local _2_0 = getmetatable(_0_0)
        if _2_0 then
          return _2_0.__fennelview
        else
          return _2_0
        end
      else
        return _0_0
      end
    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), ">")
    elseif (self.level >= self.depth) then
      return puts(self, "{...}")
    elseif metamethod then
      return puts(self, metamethod(t, self.fennelview))
    elseif "else" then
      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
        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, _3_())
      elseif (#non_seq_keys == 0) then
        return put_sequential_table(self, t, len)
      elseif "else" then
        return put_kv_table(self, t, non_seq_keys)
      end
    end
  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))
    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
  put_value = _0_
  local function one_line(str)
    local ret = str:gsub("\n", " "):gsub("%[ ", "["):gsub(" %]", "]"):gsub("%{ ", "{"):gsub(" %}", "}"):gsub("%( ", "("):gsub(" %)", ")")
    return ret
  end
  local function fennelview(x, options)
    local options0 = (options or {})
    local inspector = nil
    local function _1_(_241)
      return fennelview(_241, options0)
    end
    local function _2_()
      if options0["one-line"] then
        return ""
      else
        return "  "
      end
    end
    inspector = {["detect-cycles?"] = not (false == options0["detect-cycles?"]), ["empty-as-square"] = options0["empty-as-square"], ["max-ids"] = {}, ["metamethod?"] = not (false == options0["metamethod?"]), ["table-edges"] = (options0["table-edges"] ~= false), appearances = count_table_appearances(x, {}), buffer = {}, depth = (options0.depth or 128), fennelview = _1_, ids = {}, indent = (options0.indent or _2_()), level = 0}
    put_value(inspector, x)
    local str = table.concat(inspector.buffer)
    if options0["one-line"] then
      return one_line(str)
    else
      return str
    end
  end
  return fennelview
end
local fennel = nil
package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
  local utils = require("fennel.utils")


@@ 404,7 167,7 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
      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")
        return (compiler.traceback(tostring(err), 4) .. "\n")
      else
        local _ = _0_0
        return ("%s error: %s\n"):format(errtype, tostring(err))


@@ 432,9 195,21 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
  local function command_3f(input)
    return input:match("^%s*,")
  end
  local function command_docs()
    local _0_
    do
      local tbl_0_ = {}
      for name, f in pairs(commands) do
        tbl_0_[(#tbl_0_ + 1)] = ("  ,%s - %s"):format(name, ((compiler.metadata):get(f, "fnl/docstring") or "undocumented"))
      end
      _0_ = tbl_0_
    end
    return table.concat(_0_, "\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  ,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"})
    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 _0_0, _1_0 = pcall(specials["load-code"]("return require(...)", env), module_name)
    if ((_0_0 == true) and (nil ~= _1_0)) then


@@ 445,7 220,7 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
      local ok, new = pcall(require, module_name)
      local new0 = nil
      if not ok then
        on_values(new)
        on_values({new})
        new0 = old
      else
        new0 = new


@@ 471,7 246,7 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
      return on_error("Runtime", _3_())
    end
  end
  commands.reload = function(read, env, on_values, on_error)
  commands.reload = function(env, read, 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


@@ 482,17 257,34 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
      return on_error("Parse", (_3fmsg or _3fparse_ok))
    end
  end
  commands.reset = function(_, env, on_values)
  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.")
  local function load_plugin_commands()
    if (utils.root and utils.root.options and utils.root.options.plugins) then
      for _, plugin in ipairs(utils.root.options.plugins) do
        for name, f in pairs(plugin) do
          local _0_0 = name:match("^repl%-command%-(.*)")
          if (nil ~= _0_0) then
            local cmd_name = _0_0
            commands[cmd_name] = (commands[cmd_name] or f)
          end
        end
      end
      return nil
    end
  end
  local function run_command(input, read, loop, env, on_values, on_error)
    load_plugin_commands()
    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)
        command(env, read, on_values, on_error)
      else
        local _ = _0_0
        if ("exit" ~= command_name) then


@@ 556,7 348,7 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
    if options.env then
      env = specials["wrap-env"](options.env)
    else
      env = setmetatable({}, {__index = (_G._ENV or _G)})
      env = setmetatable({}, {__index = (rawget(_G, "_ENV") or _G)})
    end
    local save_locals_3f = ((options.saveLocals ~= false) and env.debug and env.debug.getlocal)
    local opts = {}


@@ 603,7 395,7 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
        chars[k] = nil
      end
      local ok, parse_ok_3f, x = pcall(read)
      local src_string = string.char((_G.unpack or table.unpack)(chars))
      local src_string = string.char((table.unpack or _G.unpack)(chars))
      utils.root.options = opts
      if not ok then
        on_error("Parse", parse_ok_3f)


@@ 655,11 447,396 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
  end
  return repl
end
package.preload["fennel.view"] = package.preload["fennel.view"] or function(...)
  local type_order = {["function"] = 5, boolean = 2, number = 1, string = 3, table = 4, thread = 7, userdata = 6}
  local function sort_keys(_0_0, _1_0)
    local _1_ = _0_0
    local a = _1_[1]
    local _2_ = _1_0
    local b = _2_[1]
    local ta = type(a)
    local tb = type(b)
    if ((ta == tb) and ((ta == "string") or (ta == "number"))) then
      return (a < b)
    else
      local dta = type_order[ta]
      local dtb = type_order[tb]
      if (dta and dtb) then
        return (dta < dtb)
      elseif dta then
        return true
      elseif dtb then
        return false
      else
        return (ta < tb)
      end
    end
  end
  local function table_kv_pairs(t)
    local assoc_3f = false
    local i = 1
    local kv = {}
    local insert = table.insert
    for k, v in pairs(t) do
      if ((type(k) ~= "number") or (k ~= i)) then
        assoc_3f = true
      end
      i = (i + 1)
      insert(kv, {k, v})
    end
    table.sort(kv, sort_keys)
    if (#kv == 0) then
      return kv, "empty"
    else
      local function _2_()
        if assoc_3f then
          return "table"
        else
          return "seq"
        end
      end
      return kv, _2_()
    end
  end
  local function count_table_appearances(t, appearances)
    if (type(t) == "table") then
      if not appearances[t] then
        appearances[t] = 1
        for k, v in pairs(t) do
          count_table_appearances(k, appearances)
          count_table_appearances(v, appearances)
        end
      else
        appearances[t] = ((appearances[t] or 0) + 1)
      end
    end
    return appearances
  end
  local function save_table(t, seen)
    local seen0 = (seen or {len = 0})
    local id = (seen0.len + 1)
    if not seen0[t] then
      seen0[t] = id
      seen0.len = id
    end
    return seen0
  end
  local function detect_cycle(t, seen, _3fk)
    if ("table" == type(t)) then
      seen[t] = true
      local _2_0, _3_0 = next(t, _3fk)
      if ((nil ~= _2_0) and (nil ~= _3_0)) then
        local k = _2_0
        local v = _3_0
        return (seen[k] or detect_cycle(k, seen) or seen[v] or detect_cycle(v, seen) or detect_cycle(t, seen, k))
      end
    end
  end
  local function visible_cycle_3f(t, options)
    return (options["detect-cycles?"] and detect_cycle(t, {}) and save_table(t, options.seen) and (1 < (options.appearances[t] or 0)))
  end
  local function table_indent(t, indent, id)
    local opener_length = nil
    if id then
      opener_length = (#tostring(id) + 2)
    else
      opener_length = 1
    end
    return (indent + opener_length)
  end
  local pp = nil
  local function concat_table_lines(elements, options, multiline_3f, indent, table_type, prefix)
    local indent_str = ("\n" .. string.rep(" ", indent))
    local open = nil
    local function _2_()
      if ("seq" == table_type) then
        return "["
      else
        return "{"
      end
    end
    open = ((prefix or "") .. _2_())
    local close = nil
    if ("seq" == table_type) then
      close = "]"
    else
      close = "}"
    end
    local oneline = (open .. table.concat(elements, " ") .. close)
    if (not options["one-line?"] and (multiline_3f or ((indent + #oneline) > options["line-length"]))) then
      return (open .. table.concat(elements, indent_str) .. close)
    else
      return oneline
    end
  end
  local function pp_associative(t, kv, options, indent, key_3f)
    local multiline_3f = false
    local id = options.seen[t]
    if (options.level >= options.depth) then
      return "{...}"
    elseif (id and options["detect-cycles?"]) then
      return ("@" .. id .. "{...}")
    else
      local visible_cycle_3f0 = visible_cycle_3f(t, options)
      local id0 = (visible_cycle_3f0 and options.seen[t])
      local indent0 = table_indent(t, indent, id0)
      local slength = nil
      local function _3_()
        local _2_0 = rawget(_G, "utf8")
        if _2_0 then
          return _2_0.len
        else
          return _2_0
        end
      end
      local function _4_(_241)
        return #_241
      end
      slength = ((options["utf8?"] and _3_()) or _4_)
      local prefix = nil
      if visible_cycle_3f0 then
        prefix = ("@" .. id0)
      else
        prefix = ""
      end
      local elements = nil
      do
        local tbl_0_ = {}
        for _, _6_0 in pairs(kv) do
          local _7_ = _6_0
          local k = _7_[1]
          local v = _7_[2]
          local _8_
          do
            local k0 = pp(k, options, (indent0 + 1), true)
            local v0 = pp(v, options, (indent0 + slength(k0) + 1))
            multiline_3f = (multiline_3f or k0:find("\n") or v0:find("\n"))
            _8_ = (k0 .. " " .. v0)
          end
          tbl_0_[(#tbl_0_ + 1)] = _8_
        end
        elements = tbl_0_
      end
      return concat_table_lines(elements, options, multiline_3f, indent0, "table", prefix)
    end
  end
  local function pp_sequence(t, kv, options, indent)
    local multiline_3f = false
    local id = options.seen[t]
    if (options.level >= options.depth) then
      return "[...]"
    elseif (id and options["detect-cycles?"]) then
      return ("@" .. id .. "[...]")
    else
      local visible_cycle_3f0 = visible_cycle_3f(t, options)
      local id0 = (visible_cycle_3f0 and options.seen[t])
      local indent0 = table_indent(t, indent, id0)
      local prefix = nil
      if visible_cycle_3f0 then
        prefix = ("@" .. id0)
      else
        prefix = ""
      end
      local elements = nil
      do
        local tbl_0_ = {}
        for _, _3_0 in pairs(kv) do
          local _4_ = _3_0
          local _0 = _4_[1]
          local v = _4_[2]
          local _5_
          do
            local v0 = pp(v, options, indent0)
            multiline_3f = (multiline_3f or v0:find("\n"))
            _5_ = v0
          end
          tbl_0_[(#tbl_0_ + 1)] = _5_
        end
        elements = tbl_0_
      end
      return concat_table_lines(elements, options, multiline_3f, indent0, "seq", prefix)
    end
  end
  local function concat_lines(lines, options, indent, force_multi_line_3f)
    if (#lines == 0) then
      if options["empty-as-sequence?"] then
        return "[]"
      else
        return "{}"
      end
    else
      local oneline = nil
      local _2_
      do
        local tbl_0_ = {}
        for _, line in ipairs(lines) do
          tbl_0_[(#tbl_0_ + 1)] = line:gsub("^%s+", "")
        end
        _2_ = tbl_0_
      end
      oneline = table.concat(_2_, " ")
      if (not options["one-line?"] and (force_multi_line_3f or oneline:find("\n") or ((indent + #oneline) > options["line-length"]))) then
        return table.concat(lines, ("\n" .. string.rep(" ", indent)))
      else
        return oneline
      end
    end
  end
  local function pp_metamethod(t, metamethod, options, indent)
    if (options.level >= options.depth) then
      if options["empty-as-sequence?"] then
        return "[...]"
      else
        return "{...}"
      end
    else
      local _ = nil
      local function _2_(_241)
        return visible_cycle_3f(_241, options)
      end
      options["visible-cycle?"] = _2_
      _ = nil
      local lines, force_multi_line_3f = metamethod(t, pp, options, indent)
      options["visible-cycle?"] = nil
      local _3_0 = type(lines)
      if (_3_0 == "string") then
        return lines
      elseif (_3_0 == "table") then
        return concat_lines(lines, options, indent, force_multi_line_3f)
      else
        local _0 = _3_0
        return error("Error: __fennelview metamethod must return a table of lines")
      end
    end
  end
  local function pp_table(x, options, indent)
    options.level = (options.level + 1)
    local x0 = nil
    do
      local _2_0 = nil
      if options["metamethod?"] then
        local _3_0 = x
        if _3_0 then
          local _4_0 = getmetatable(_3_0)
          if _4_0 then
            _2_0 = _4_0.__fennelview
          else
            _2_0 = _4_0
          end
        else
          _2_0 = _3_0
        end
      else
      _2_0 = nil
      end
      if (nil ~= _2_0) then
        local metamethod = _2_0
        x0 = pp_metamethod(x, metamethod, options, indent)
      else
        local _ = _2_0
        local _4_0, _5_0 = table_kv_pairs(x)
        if (true and (_5_0 == "empty")) then
          local _0 = _4_0
          if options["empty-as-sequence?"] then
            x0 = "[]"
          else
            x0 = "{}"
          end
        elseif ((nil ~= _4_0) and (_5_0 == "table")) then
          local kv = _4_0
          x0 = pp_associative(x, kv, options, indent)
        elseif ((nil ~= _4_0) and (_5_0 == "seq")) then
          local kv = _4_0
          x0 = pp_sequence(x, kv, options, indent)
        else
        x0 = nil
        end
      end
    end
    options.level = (options.level - 1)
    return x0
  end
  local function number__3estring(n)
    local _2_0 = string.gsub(tostring(n), ",", ".")
    return _2_0
  end
  local function colon_string_3f(s)
    return s:find("^[-%w?^_!$%&*+./@|<=>]+$")
  end
  local function pp_string(str, options, indent)
    local escs = nil
    local _2_
    if (options["escape-newlines?"] and (#str < (options["line-length"] - indent))) then
      _2_ = "\\n"
    else
      _2_ = "\n"
    end
    local function _4_(_241, _242)
      return ("\\%03d"):format(_242:byte())
    end
    escs = setmetatable({["\""] = "\\\"", ["\11"] = "\\v", ["\12"] = "\\f", ["\13"] = "\\r", ["\7"] = "\\a", ["\8"] = "\\b", ["\9"] = "\\t", ["\\"] = "\\\\", ["\n"] = _2_}, {__index = _4_})
    return ("\"" .. str:gsub("[%c\\\"]", escs) .. "\"")
  end
  local function make_options(t, options)
    local defaults = {["detect-cycles?"] = true, ["empty-as-sequence?"] = false, ["escape-newlines?"] = false, ["line-length"] = 80, ["metamethod?"] = true, ["one-line?"] = false, ["prefer-colon?"] = false, ["utf8?"] = true, depth = 128}
    local overrides = {appearances = count_table_appearances(t, {}), level = 0, seen = {len = 0}}
    for k, v in pairs((options or {})) do
      defaults[k] = v
    end
    for k, v in pairs(overrides) do
      defaults[k] = v
    end
    return defaults
  end
  local function _2_(x, options, indent, colon_3f)
    local indent0 = (indent or 0)
    local options0 = (options or make_options(x))
    local tv = type(x)
    local function _4_()
      local _3_0 = getmetatable(x)
      if _3_0 then
        return _3_0.__fennelview
      else
        return _3_0
      end
    end
    if ((tv == "table") or ((tv == "userdata") and _4_())) then
      return pp_table(x, options0, indent0)
    elseif (tv == "number") then
      return number__3estring(x)
    else
      local function _5_()
        if (colon_3f ~= nil) then
          return colon_3f
        elseif ("function" == type(options0["prefer-colon?"])) then
          return options0["prefer-colon?"](x)
        else
          return options0["prefer-colon?"]
        end
      end
      if ((tv == "string") and colon_string_3f(x) and _5_()) then
        return (":" .. x)
      elseif (tv == "string") then
        return pp_string(x, options0, indent0)
      elseif ((tv == "boolean") or (tv == "nil")) then
        return tostring(x)
      else
        return ("#<" .. tostring(x) .. ">")
      end
    end
  end
  pp = _2_
  local function view(x, options)
    return pp(x, make_options(x, options), 0)
  end
  return view
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 = (_G.unpack or table.unpack)
  local unpack = (table.unpack or _G.unpack)
  local SPECIALS = compiler.scopes.global.specials
  local function wrap_env(env)
    local function _0_(_, key)


@@ 696,8 873,8 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
    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 environment0 = (environment or rawget(_G, "_ENV") or _G)
    if (rawget(_G, "setfenv") and rawget(_G, "loadstring")) then
      local f = assert(_G.loadstring(code, filename))
      _G.setfenv(f, environment0)
      return f


@@ 710,7 887,8 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
      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 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 _0_
        if (#arglist > 0) then


@@ 803,15 981,41 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
    return exprs
  end
  doc_special("values", {"..."}, "Return multiple values from a function. Must be in tail position.")
  local function deep_tostring(x, key_3f)
    local elems = {}
    if utils["sequence?"](x) then
      local _0_
      do
        local tbl_0_ = {}
        for _, v in ipairs(x) do
          tbl_0_[(#tbl_0_ + 1)] = deep_tostring(v)
        end
        _0_ = tbl_0_
      end
      return ("[" .. table.concat(_0_, " ") .. "]")
    elseif utils["table?"](x) then
      local _0_
      do
        local tbl_0_ = {}
        for k, v in pairs(x) do
          tbl_0_[(#tbl_0_ + 1)] = (deep_tostring(k, true) .. " " .. deep_tostring(v))
        end
        _0_ = tbl_0_
      end
      return ("{" .. table.concat(_0_, " ") .. "}")
    elseif (key_3f and (type(x) == "string") and x:find("^[-%w?\\^_!$%&*+./@:|<=>]+$")) then
      return (":" .. x)
    elseif (type(x) == "string") then
      return string.format("%q", x):gsub("\\\"", "\\\\\""):gsub("\"", "\\\"")
    else
      return tostring(x)
    end
  end
  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
        return ("\"%s\""):format(deep_tostring(v))
      end
      args = utils.map(arg_list, _0_)
      local meta_fields = {"\"fnl/arglist\"", ("{" .. table.concat(args, ", ") .. "}")}


@@ 859,7 1063,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
      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})
        compiler.destructure(arg, raw, ast, f_scope, f_chunk, {declaration = true, nomulti = true, symtype = "arg"})
        return declared
      else
        return compiler.assert(false, ("expected symbol for function parameter: %s"):format(tostring(arg)), ast[2])


@@ 896,7 1100,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
    if (ast[2] ~= nil) then
      table.insert(parent, {ast = ast, leaf = tostring(ast[2])})
    end
    if (#ast == 3) then
    if (ast[3] ~= nil) then
      return tostring(ast[3])
    end
  end


@@ 932,7 1136,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
          table.insert(indices, ("[" .. tostring(index0) .. "]"))
        end
      end
      if (tostring(lhs):find("{") or ("nil" == tostring(lhs))) then
      if (tostring(lhs):find("[{\"0-9]") or ("nil" == tostring(lhs))) then
        return ("(" .. tostring(lhs) .. ")" .. table.concat(indices))
      else
        return (tostring(lhs) .. table.concat(indices))


@@ 943,32 1147,32 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
  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})
    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})
    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})
    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})
    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})
    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.")


@@ 984,7 1188,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
    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})
      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


@@ 1135,7 1339,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
    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})
      compiler.destructure(args, raw, ast, sub_scope, chunk, {declaration = true, nomulti = true, symtype = "each"})
    end
    compiler["apply-manglings"](sub_scope, new_manglings, ast)
    compile_do(ast, sub_scope, chunk, 3)


@@ 1436,7 1640,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
  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 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 a :compilerEnv globals table 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


@@ 1445,8 1649,22 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
    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 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(strict_3f)
    local _1_
    if strict_3f then
      _1_ = compiler_env_warn
    else
    _1_ = nil
    end
    return setmetatable({assert = assert, bit = rawget(_G, "bit"), error = error, getmetatable = safe_getmetatable, ipairs = ipairs, math = utils.copy(math), next = next, pairs = pairs, 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, xpcall = xpcall}, {__index = _1_})
  end
  local function make_compiler_env(ast, scope, parent, strict_3f)
    local function _1_()
      return compiler.scopes.macro
    end


@@ 1464,15 1682,20 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
    local _6_
    do
      local _5_0 = utils.root.options
      if ((type(_5_0) == "table") and (nil ~= _5_0["compiler-env"])) then
      if ((type(_5_0) == "table") and (_5_0["compiler-env"] == "strict")) then
        _6_ = safe_compiler_env(true)
      elseif ((type(_5_0) == "table") and (nil ~= _5_0.compilerEnv)) then
        local compilerEnv = _5_0.compilerEnv
        _6_ = compilerEnv
      elseif ((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
        _6_ = safe_compiler_env(false)
      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_})
    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, view = view}, {__index = _6_})
  end
  local cfg = string.gmatch(package.config, "([^\n]+)")
  local dirsep, pathsep, pathmark = (cfg() or "/"), (cfg() or ";"), (cfg() or "?")


@@ 1510,6 1733,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
      for k, v in pairs((options or {})) do
        opts[k] = v
      end
      opts["module-name"] = module_name
      local _2_0 = search_module(module_name)
      if (nil ~= _2_0) then
        local filename = _2_0


@@ 1528,10 1752,11 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
    end
    return allowed
  end
  local function compiler_env_domodule(modname, env, _3fast)
  local function compiler_env_domodule(modname, env, _3fast, _3fscope)
    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)
    local scope = (_3fscope or compiler["make-scope"](compiler.scopes.compiler))
    return utils["fennel-module"].dofile(filename, {allowedGlobals = globals, env = env, scope = scope, useMetadata = utils.root.options.useMetadata}, modname, filename)
  end
  local macro_loaded = {}
  local function metadata_only_fennel(modname)


@@ 1539,14 1764,17 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
      return {metadata = compiler.metadata}
    end
  end
  safe_compiler_env.require = function(modname)
    local function _1_()
      local mod = compiler_env_domodule(modname, safe_compiler_env)
  local function _1_(modname)
    local function _2_()
      local scope = compiler["make-scope"](compiler.scopes.compiler)
      local env = make_compiler_env(nil, scope, nil)
      local mod = compiler_env_domodule(modname, env, nil, scope)
      macro_loaded[modname] = mod
      return mod
    end
    return (macro_loaded[modname] or metadata_only_fennel(modname) or _1_())
    return (macro_loaded[modname] or metadata_only_fennel(modname) or _2_())
  end
  safe_require = _1_
  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


@@ 1555,9 1783,12 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
    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]
  SPECIALS["require-macros"] = function(ast, scope, parent, real_ast)
    compiler.assert((#ast == 2), "Expected one module name argument", (real_ast or ast))
    local filename = (ast[2].filename or ast.filename)
    local modname_code = compiler.compile(ast[2])
    local modname = load_code(modname_code, nil, filename)(utils.root.options["module-name"], filename)
    compiler.assert((type(modname) == "string"), "module name must compile to string", (real_ast or ast))
    if not macro_loaded[modname] then
      local env = make_compiler_env(ast, scope, parent)
      macro_loaded[modname] = compiler_env_domodule(modname, env, ast)


@@ 1599,10 1830,10 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
          return error(..., 0)
        end
      end
      local function _1_()
      local function _2_()
        return f:read("*all"):gsub("[\13\n]*$", "")
      end
      src = close_handlers_0_(xpcall(_1_, (package.loaded.fennel or debug).traceback))
      src = close_handlers_0_(xpcall(_2_, (package.loaded.fennel or debug).traceback))
    end
    local ret = utils.expr(("require(\"" .. mod .. "\")"), "statement")
    local target = ("package.preload[%q]"):format(mod)


@@ 1639,13 1870,13 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
      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
      local function _3_()
        local _2_0 = search_module(mod)
        if (nil ~= _2_0) then
          local fennel_path = _2_0
          return include_path(ast, opts, fennel_path, mod, true)
        else
          local _ = _1_0
          local _ = _2_0
          local lua_path = search_module(mod, package.path)
          if lua_path then
            return include_path(ast, opts, lua_path, mod, false)


@@ 1656,7 1887,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
          end
        end
      end
      return (include_circular_fallback(mod, modexpr, opts.fallback, ast) or utils.root.scope.includes[mod] or _2_())
      return (include_circular_fallback(mod, modexpr, opts.fallback, ast) or utils.root.scope.includes[mod] or _3_())
    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.")


@@ 1665,7 1896,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
    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))()
    return 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)


@@ 1686,7 1917,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
  local utils = require("fennel.utils")
  local parser = require("fennel.parser")
  local friend = require("fennel.friend")
  local unpack = (_G.unpack or table.unpack)
  local unpack = (table.unpack or _G.unpack)
  local scopes = {}
  local function make_scope(parent)
    local parent0 = (parent or scopes.global)


@@ 1698,6 1929,27 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
    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_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 target = nil
    local function _1_()
      if utils["sym?"](ast_tbl[1]) then
        return utils.deref(ast_tbl[1])
      else
        return (ast_tbl[1] or "()")
      end
    end
    target = tostring(_1_())
    return string.format("Compile error in '%s' %s:%s: %s", target, filename, line, msg)
  end
  local function assert_compile(condition, msg, ast)
    if not condition then
      local _0_ = (utils.root.options or {})


@@ 1705,19 1957,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
      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)
        error(assert_msg(ast, msg), 0)
      else
        friend["assert-compile"](condition, msg, ast, source)
      end


@@ 1839,8 2079,13 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
      return (scope.autogensyms[base] or _1_())
    end
  end
  local already_warned = {}
  local function check_binding_valid(symbol, scope, ast)
    local name = utils.deref(symbol)
    if (io and io.stderr and name:find("&") and not already_warned[symbol]) then
      already_warned[symbol] = true
      do end (io.stderr):write(("-- Warning: & will not be allowed in identifier names in " .. "future versions: " .. (symbol.filename or "unknown") .. ":" .. (symbol.line or "?") .. "\n"))
    end
    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


@@ 1874,7 2119,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
    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)
    assert_compile((not reference_3f or local_3f or global_allowed(parts[1])), ("unknown global in strict mode: " .. tostring(parts[1])), symbol)
    if (allowed_globals and not local_3f) then
      utils.root.scope.refedglobals[parts[1]] = true
    end


@@ 1904,6 2149,10 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
      return utils.map(chunk, peephole)
    end
  end
  local function ast_source(ast)
    local m = getmetatable(ast)
    return ((m and m.line and m) or (("table" == type(ast)) and ast) or {})
  end
  local function flatten_chunk_correlated(main_chunk)
    local function flatten(chunk, out, last_line, file)
      local last_line0 = last_line


@@ 1912,8 2161,9 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
      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))
            local source = ast_source(subchunk.ast)
            if (file == source.file) then
              last_line0 = math.max(last_line0, (source.line or 0))
            end
            last_line0 = flatten(subchunk, out, last_line0, file)
          end


@@ 1935,7 2185,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
      local code = chunk.leaf
      local info = chunk.ast
      if sm then
        table.insert(sm, ((info and info.line) or ( - 1)))
        table.insert(sm, {(info and info.filename), (info and info.line)})
      end
      return code
    else


@@ 1984,7 2234,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
      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))
        sm.short_src = (options.filename or make_short_src((options.source or ret)))
        if options.filename then
          sm.key = ("@" .. options.filename)
        else


@@ 2195,6 2445,10 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
    end
    return handle_compile_opts({e}, parent, opts, ast)
  end
  local function serialize_number(n)
    local _0_0 = string.gsub(tostring(n), ",", ".")
    return _0_0
  end
  local function compile_scalar(ast, _scope, parent, opts)
    local serialize = nil
    do


@@ 2206,10 2460,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
      elseif (_0_0 == "string") then
        serialize = serialize_string
      elseif (_0_0 == "number") then
        local function _1_(...)
          return string.format("%.17g", ...)
        end
        serialize = _1_
        serialize = serialize_number
      else
      serialize = nil
      end


@@ 2278,6 2529,8 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
    local isvar = _0_["isvar"]
    local nomulti = _0_["nomulti"]
    local noundef = _0_["noundef"]
    local symtype = _0_["symtype"]
    local symtype0 = ("_" .. (symtype or "dst"))
    local setter = nil
    if declaration then
      setter = "local %s = %s"


@@ 2337,38 2590,53 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
      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
    local function destructure_sym(left, rightexprs, up1, top_3f)
      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}
        return nil
      end
    end
    local function destructure_table(left, rightexprs, top_3f, destructure1)
      local s = gensym(scope, symtype0)
      local right = nil
      do
        local _2_0 = nil
        if top_3f then
          right = exprs1(compile1(from, scope, parent))
          _2_0 = exprs1(compile1(from, scope, parent))
        else
          right = exprs1(rightexprs)
          _2_0 = exprs1(rightexprs)
        end
        if (right == "") then
        if (_2_0 == "") then
          right = "nil"
        elseif (nil ~= _2_0) then
          local right0 = _2_0
          right = right0
        else
        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)
      end
      emit(parent, string.format("local %s = %s", s, right), left)
      for k, v in utils.stablepairs(left) do
        if not (("number" == type(k)) and tostring(left[(k - 1)]):find("^&")) then
          if (utils["sym?"](v) and (utils.deref(v) == "&")) then
            local unpack_str = "{(table.unpack or unpack)(%s, %s)}"
            local formatted = string.format(unpack_str, s, k)
            local subexpr = utils.expr(formatted, "expression")
            assert_compile((utils["sequence?"](left) and (nil == left[(k + 2)])), "expected rest argument before last parameter", left)
            destructure1(left[(k + 1)], {subexpr}, left)
            return
          elseif (utils["sym?"](k) and (utils.deref(k) == "&as")) then
            destructure_sym(v, {utils.expr(tostring(s))}, left)
          elseif (utils["sequence?"](left) and (utils.deref(v) == "&as")) then
            local _, next_sym, trailing = select(k, unpack(left))
            assert_compile((nil == trailing), "expected &as argument before last parameter", left)
            destructure_sym(next_sym, {utils.expr(tostring(s))}, left)
          else
            local key = nil
            if (type(k) == "string") then


@@ 2380,27 2648,39 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
            destructure1(v, {subexpr}, left)
          end
        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
        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
      end
      return nil
    end
    local function destructure_values(left, up1, top_3f, destructure1)
      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, symtype0)
          table.insert(left_names, symname)
          tables[i] = {name, utils.expr(symname, "sym")}
        end
        for _, pair in utils.stablepairs(tables) do
          destructure1(pair[1], {pair[2]}, left)
      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
      end
      for _, pair in utils.stablepairs(tables) do
        destructure1(pair[1], {pair[2]}, left)
      end
      return nil
    end
    local function destructure1(left, rightexprs, up1, top_3f)
      if (utils["sym?"](left) and (left[1] ~= "nil")) then
        destructure_sym(left, rightexprs, up1, top_3f)
      elseif utils["table?"](left) then
        destructure_table(left, rightexprs, top_3f, destructure1)
      elseif utils["list?"](left) then
        destructure_values(left, up1, top_3f, destructure1)
      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


@@ 2478,8 2758,12 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
    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]
        if remap[info.currentline][1] then
          info.short_src = fennel_sourcemap[("@" .. remap[info.currentline][1])].short_src
        else
          info.short_src = remap.short_src
        end
        info.currentline = (remap[info.currentline][2] or -1)
      end
      if (info.what == "Lua") then
        local function _1_()


@@ 2490,7 2774,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
          end
        end
        return string.format("  %s:%d: in function %s", info.short_src, info.currentline, _1_())
      elseif (info["short-src"] == "(tail call)") then
      elseif (info.short_src == "(tail call)") then
        return "  (tail call)"
      else
        return string.format("  %s:%d: in main chunk", info.short_src, info.currentline)


@@ 2590,6 2874,22 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
      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 utils["sequence?"](form) 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 _1_
      if source then
        _1_ = source.line
      else
        _1_ = "nil"
      end
      return string.format("setmetatable({%s}, {filename=%s, line=%s, sequence=%s})", mixed_concat(mapped, ", "), filename, _1_, "(getmetatable(sequence()))['sequence']")
    elseif (type(form) == "table") then
      local mapped = utils.kvmap(form, entry_transform(q, q))
      local source = getmetatable(form)


@@ 2618,10 2918,10 @@ 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 {})
    return ((m and m.line and m) or (("table" == type(ast)) and 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 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 to return a list or table"}, ["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 = (table.unpack or _G.unpack)
  local function suggest(msg)
    local suggestion = nil
    for pat, sug in pairs(suggestions) do


@@ 2652,21 2952,19 @@ package.preload["fennel.friend"] = package.preload["fennel.friend"] or function(
    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)
  local function read_line_from_string(matcher, target_line, _3fcurrent_line, _3fbytes)
    local this_line, newline = matcher()
    local current_line = (_3fcurrent_line or 1)
    local bytes = ((_3fbytes or 0) + #this_line + #newline)
    if (target_line == current_line) then
      return this_line, bytes
    elseif this_line then
      return read_line_from_string(matcher, target_line, (current_line + 1), bytes)
    end
    return codeline, bytes
  end
  local function read_line(filename, line, source)
    if source then
      return read_line_from_source(source, line)
      return read_line_from_string(string.gmatch((source .. "\n"), "(.-)(\13?\n)"), line)
    else
      return read_line_from_file(filename, line)
    end


@@ 2714,7 3012,7 @@ 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 unpack = (table.unpack or _G.unpack)
  local function granulate(getchunk)
    local c, index, done_3f = "", 1, false
    local function _0_(parser_state)


@@ 2750,7 3048,7 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(
    return _0_, _1_
  end
  local function string_stream(str)
    local str0 = str:gsub("^#![^\n]*\n", "")
    local str0 = str:gsub("^#!", ";;")
    local index = 1
    local function _0_()
      local r = str0:byte(index)


@@ 2763,8 3061,14 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(
  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))
  local function sym_char_3f(b)
    local b0 = nil
    if ("number" == type(b)) then
      b0 = b
    else
      b0 = string.byte(b)
    end
    return ((b0 > 32) and not delims[b0] and (b0 ~= 127) and (b0 ~= 34) and (b0 ~= 39) and (b0 ~= 126) and (b0 ~= 59) and (b0 ~= 44) and (b0 ~= 64) and (b0 ~= 96))
  end
  local prefixes = {[35] = "hashfn", [39] = "quote", [44] = "unquote", [96] = "quote"}
  local function parser(getbyte, filename, options)


@@ 2793,6 3097,7 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(
      end
      return r
    end
    assert(((nil == filename) or ("string" == type(filename))), "expected filename as second argument to parser")
    local function parse_error(msg, byteindex_override)
      local _0_ = (options or utils.root.options or {})
      local source = _0_["source"]


@@ 2813,8 3118,17 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(
          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))
          local source = nil
          do
            local _1_0 = table.remove(stack)
            _1_0["byteend"] = byteindex
            source = _1_0
          end
          local list = utils.list(utils.sym(prefix, source), v)
          for k, v0 in pairs(source) do
            list[k] = v0
          end
          return dispatch(list)
        elseif (nil ~= _0_0) then
          local top = _0_0
          whitespace_since_dispatch = false


@@ 2841,9 3155,16 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(
          return b
        end
      end
      local function skip_comment(b)
      local function parse_comment(b, contents)
        if (b and (10 ~= b)) then
          return skip_comment(getb())
          local function _1_()
            local _0_0 = contents
            table.insert(_0_0, string.char(b))
            return _0_0
          end
          return parse_comment(getb(), _1_())
        elseif (options and options.comments) then
          return dispatch(utils.comment(table.concat(contents), {filename = filename, line = (line - 1)}))
        else
          return b
        end


@@ 2864,7 3185,35 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(
        end
        return dispatch(val)
      end
      local function extract_comments(tbl)
        local comments = nil
        local _0_
        if utils["comment?"](tbl[#tbl]) then
          _0_ = table.remove(tbl)
        else
        _0_ = nil
        end
        comments = {keys = {}, last = _0_, values = {}}
        local last_key_3f = false
        for i, node in ipairs(tbl) do
          if not utils["comment?"](node) then
            last_key_3f = not last_key_3f
          elseif last_key_3f then
            comments.values[tbl[(i + 1)]] = node
          else
            comments.keys[tbl[(i + 1)]] = node
          end
        end
        for i = #tbl, 1, -1 do
          if utils["comment?"](tbl[i]) then
            table.remove(tbl, i)
          end
        end
        return comments
      end
      local function close_curly_table(tbl)
        local comments = extract_comments(tbl)
        local keys = {}
        local val = {}
        if ((#tbl % 2) ~= 0) then
          byteindex = (byteindex - 1)


@@ 2876,7 3225,10 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(
            tbl[i] = tostring(tbl[(i + 1)])
          end
          val[tbl[i]] = tbl[(i + 1)]
          table.insert(keys, tbl[i])
        end
        tbl.comments = comments
        tbl.keys = keys
        return dispatch(val)
      end
      local function close_table(b)


@@ 2884,7 3236,7 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(
        if (top == nil) then
          parse_error(("unexpected closing delimiter " .. string.char(b)))
        end
        if (top.closer ~= b) then
        if (top.closer and (top.closer ~= b)) then
          parse_error(("mismatched closing delimiter " .. string.char(b) .. ", expected " .. string.char(top.closer)))
        end
        top.byteend = byteindex


@@ 2916,6 3268,9 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(
          return b
        end
      end
      local function escape_char(c)
        return ({[10] = "\\n", [11] = "\\v", [12] = "\\f", [13] = "\\r", [7] = "\\a", [8] = "\\b", [9] = "\\t"})[c:byte()]
      end
      local function parse_string()
        table.insert(stack, {closer = 34})
        local chars = {34}


@@ 2924,18 3279,14 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(
        end
        table.remove(stack)
        local raw = string.char(unpack(chars))
        local formatted = nil
        local function _1_(c)
          return ("\\" .. c:byte())
        end
        formatted = raw:gsub("[\1-\31]", _1_)
        local load_fn = (_G.loadstring or load)(("return " .. formatted))
        local formatted = raw:gsub("[\7-\13]", escape_char)
        local load_fn = (rawget(_G, "loadstring") or load)(("return " .. formatted))
        return dispatch(load_fn())
      end
      local function parse_prefix(b)
        table.insert(stack, {prefix = prefixes[b]})
        table.insert(stack, {bytestart = byteindex, filename = filename, line = line, prefix = prefixes[b]})
        local nextb = getb()
        if whitespace_3f(nextb) then
        if (whitespace_3f(nextb) or (true == delims[nextb])) then
          if (b ~= 35) then
            parse_error("invalid whitespace after quoting prefix")
          end


@@ 2945,7 3296,7 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(
        return ungetb(nextb)
      end
      local function parse_sym_loop(chars, b)
        if (b and symbolchar_3f(b)) then
        if (b and sym_char_3f(b)) then
          table.insert(chars, b)
          return parse_sym_loop(chars, getb())
        else


@@ 3005,7 3356,7 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(
      local function parse_loop(b)
        if not b then
        elseif (b == 59) then
          skip_comment(getb())
          parse_comment(getb(), {";"})
        elseif (type(delims[b]) == "number") then
          open_table(b)
        elseif delims[b] then


@@ 3014,7 3365,7 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(
          parse_string(b)
        elseif prefixes[b] then
          parse_prefix(b)
        elseif (symbolchar_3f(b) or (b == string.byte("~"))) then
        elseif (sym_char_3f(b) or (b == string.byte("~"))) then
          parse_sym(b)
        else
          parse_error(("illegal character: " .. string.char(b)))


@@ 3035,7 3386,7 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(
    end
    return parse_stream, _0_
  end
  return {["string-stream"] = string_stream, granulate = granulate, parser = parser}
  return {["string-stream"] = string_stream, ["sym-char?"] = sym_char_3f, granulate = granulate, parser = parser}
end
package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(...)
  local function stablepairs(t)


@@ 3052,11 3403,19 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(..
      succ[k] = keys[(i + 1)]
    end
    local function stablenext(tbl, idx)
      local key = nil
      if (idx == nil) then
        return keys[1], tbl[keys[1]]
        key = keys[1]
      else
        key = succ[idx]
      end
      local value = nil
      if (key == nil) then
        value = nil
      else
        return succ[idx], tbl[succ[idx]]
        value = tbl[key]
      end
      return key, value
    end
    return stablenext, t, nil
  end


@@ 3161,9 3520,19 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(..
    end
    return ("(" .. table.concat(map(safe, (tostring2 or tostring)), " ", 1, max) .. ")")
  end
  local symbol_mt = {"SYMBOL", __fennelview = deref, __tostring = deref}
  local function comment_view(c)
    return c, true
  end
  local function sym_3d(a, b)
    return ((deref(a) == deref(b)) and (getmetatable(a) == getmetatable(b)))
  end
  local function sym_3c(a, b)
    return (a[1] < tostring(b))
  end
  local symbol_mt = {"SYMBOL", __eq = sym_3d, __fennelview = deref, __lt = sym_3c, __tostring = deref}
  local expr_mt = {"EXPR", __tostring = deref}
  local list_mt = {"LIST", __fennelview = list__3estring, __tostring = list__3estring}
  local comment_mt = {"COMMENT", __eq = sym_3d, __fennelview = comment_view, __lt = sym_3c, __tostring = deref}
  local sequence_marker = {"SEQUENCE"}
  local vararg = setmetatable({"..."}, {"VARARG", __fennelview = deref, __tostring = deref})
  local getenv = nil


@@ 3194,6 3563,12 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(..
  local function expr(strcode, etype)
    return setmetatable({strcode, type = etype}, expr_mt)
  end
  local function comment_2a(contents, source)
    local _1_ = (source or {})
    local filename = _1_["filename"]
    local line = _1_["line"]
    return setmetatable({contents, filename = filename, line = line}, comment_mt)
  end
  local function varg()
    return vararg
  end


@@ 3216,6 3591,9 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(..
    local mt = ((type(x) == "table") and getmetatable(x))
    return (mt and (mt.sequence == sequence_marker) and x)
  end
  local function comment_3f(x)
    return ((type(x) == "table") and (getmetatable(x) == comment_mt) and x)
  end
  local function multi_sym_3f(str)
    if sym_3f(str) then
      return multi_sym_3f(tostring(str))


@@ 3259,7 3637,7 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(..
  local function valid_lua_identifier_3f(str)
    return (str:match("^[%a_][%w_]*$") and not lua_keywords[str])
  end
  local propagated_options = {"allowedGlobals", "indent", "correlate", "useMetadata", "env", "compiler-env"}
  local propagated_options = {"allowedGlobals", "indent", "correlate", "useMetadata", "env", "compiler-env", "compilerEnv"}
  local function propagate_options(options, subopts)
    for _, name in ipairs(propagated_options) do
      subopts[name] = options[name]


@@ 3294,7 3672,7 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(..
      return nil
    end
  end
  return {["debug-on?"] = debug_on_3f, ["expr?"] = expr_3f, ["list?"] = list_3f, ["lua-keywords"] = lua_keywords, ["member?"] = member_3f, ["multi-sym?"] = multi_sym_3f, ["propagate-options"] = propagate_options, ["quoted?"] = quoted_3f, ["sequence?"] = sequence_3f, ["sym?"] = sym_3f, ["table?"] = table_3f, ["valid-lua-identifier?"] = valid_lua_identifier_3f, ["varg?"] = varg_3f, ["walk-tree"] = walk_tree, allpairs = allpairs, copy = copy, deref = deref, expr = expr, hook = hook, kvmap = kvmap, list = list, map = map, path = table.concat({"./?.fnl", "./?/init.fnl", getenv("FENNEL_PATH")}, ";"), root = root, sequence = sequence, stablepairs = stablepairs, sym = sym, varg = varg}
  return {["comment?"] = comment_3f, ["debug-on?"] = debug_on_3f, ["expr?"] = expr_3f, ["list?"] = list_3f, ["lua-keywords"] = lua_keywords, ["member?"] = member_3f, ["multi-sym?"] = multi_sym_3f, ["propagate-options"] = propagate_options, ["quoted?"] = quoted_3f, ["sequence?"] = sequence_3f, ["sym?"] = sym_3f, ["table?"] = table_3f, ["valid-lua-identifier?"] = valid_lua_identifier_3f, ["varg?"] = varg_3f, ["walk-tree"] = walk_tree, allpairs = allpairs, comment = comment_2a, copy = copy, deref = deref, expr = expr, hook = hook, kvmap = kvmap, list = list, map = map, path = table.concat({"./?.fnl", "./?/init.fnl", getenv("FENNEL_PATH")}, ";"), root = root, sequence = sequence, stablepairs = stablepairs, sym = sym, varg = varg}
end
package.preload["fennel"] = package.preload["fennel"] or function(...)
  local utils = require("fennel.utils")


@@ 3302,7 3680,8 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
  local compiler = require("fennel.compiler")
  local specials = require("fennel.specials")
  local repl = require("fennel.repl")
  local function get_env(env)
  local view = require("fennel.view")
  local function eval_env(env)
    if (env == "_COMPILER") then
      local env0 = specials["make-compiler-env"](nil, compiler.scopes.compiler, {})
      local mt = getmetatable(env0)


@@ 3312,26 3691,29 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
      return (env and specials["wrap-env"](env))
    end
  end
  local function eval(str, options, ...)
  local function eval_opts(options, str)
    local opts = utils.copy(options)
    local _ = nil
    if ((opts.allowedGlobals == nil) and not getmetatable(opts.env)) then
      opts.allowedGlobals = specials["current-global-names"](opts.env)
      _ = nil
    else
    _ = nil
    end
    local env = get_env(opts.env)
    if (not opts.filename and not opts.source) then
      opts.source = str
    end
    return opts
  end
  local function eval(str, options, ...)
    local opts = eval_opts(options, str)
    local env = eval_env(opts.env)
    local lua_source = compiler["compile-string"](str, opts)
    local loader = nil
    local function _1_(...)
    local function _0_(...)
      if opts.filename then
        return ("@" .. opts.filename)
      else
        return str
      end
    end
    loader = specials["load-code"](lua_source, env, _1_(...))
    loader = specials["load-code"](lua_source, env, _0_(...))
    opts.filename = nil
    return loader(...)
  end


@@ 3343,7 3725,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
    opts.filename = filename
    return eval(source, opts, ...)
  end
  local mod = {["compile-stream"] = compiler["compile-stream"], ["compile-string"] = compiler["compile-string"], ["list?"] = utils["list?"], ["load-code"] = specials["load-code"], ["macro-loaded"] = specials["macro-loaded"], ["make-searcher"] = specials["make-searcher"], ["search-module"] = specials["search-module"], ["string-stream"] = parser["string-stream"], ["sym?"] = utils["sym?"], compile = compiler.compile, compile1 = compiler.compile1, compileStream = compiler["compile-stream"], compileString = compiler["compile-string"], doc = specials.doc, dofile = dofile_2a, eval = eval, gensym = compiler.gensym, granulate = parser.granulate, list = utils.list, loadCode = specials["load-code"], macroLoaded = specials["macro-loaded"], makeSearcher = specials["make-searcher"], make_searcher = specials["make-searcher"], mangle = compiler["global-mangling"], metadata = compiler.metadata, parser = parser.parser, path = utils.path, repl = repl, scope = compiler["make-scope"], searchModule = specials["search-module"], searcher = specials["make-searcher"](), stringStream = parser["string-stream"], sym = utils.sym, traceback = compiler.traceback, unmangle = compiler["global-unmangling"], varg = utils.varg, version = "0.7.1-dev"}
  local mod = {["comment?"] = utils["comment?"], ["compile-stream"] = compiler["compile-stream"], ["compile-string"] = compiler["compile-string"], ["list?"] = utils["list?"], ["load-code"] = specials["load-code"], ["macro-loaded"] = specials["macro-loaded"], ["make-searcher"] = specials["make-searcher"], ["search-module"] = specials["search-module"], ["sequence?"] = utils["sequence?"], ["string-stream"] = parser["string-stream"], ["sym-char?"] = parser["sym-char?"], ["sym?"] = utils["sym?"], comment = utils.comment, compile = compiler.compile, compile1 = compiler.compile1, compileStream = compiler["compile-stream"], compileString = compiler["compile-string"], doc = specials.doc, dofile = dofile_2a, eval = eval, gensym = compiler.gensym, granulate = parser.granulate, list = utils.list, loadCode = specials["load-code"], macroLoaded = specials["macro-loaded"], makeSearcher = specials["make-searcher"], make_searcher = specials["make-searcher"], mangle = compiler["global-mangling"], metadata = compiler.metadata, parser = parser.parser, path = utils.path, repl = repl, scope = compiler["make-scope"], searchModule = specials["search-module"], searcher = specials["make-searcher"](), sequence = utils.sequence, stringStream = parser["string-stream"], sym = utils.sym, traceback = compiler.traceback, unmangle = compiler["global-unmangling"], varg = utils.varg, version = "0.8.2-dev", view = view}
  utils["fennel-module"] = mod
  do
    local builtin_macros = [===[;; This module contains all the built-in Fennel macros. Unlike all the other


@@ 3356,7 3738,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
    ;; TODO: some of these macros modify their arguments; we should stop doing that,
    ;; but in a way that preserves file/line metadata.
    
    (fn -> [val ...]
    (fn ->* [val ...]
      "Thread-first macro.
    Take the first value and splice it into the second form as its first argument.
    The value of the second form is spliced into the first arg of the third, etc."


@@ 3367,7 3749,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
          (set x elt)))
      x)
    
    (fn ->> [val ...]
    (fn ->>* [val ...]
      "Thread-last macro.
    Same as ->, except splices the value into the last position of each form
    rather than the first."


@@ 3378,7 3760,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
          (set x elt)))
      x)
    
    (fn -?> [val ...]
    (fn -?>* [val ...]
      "Nil-safe thread-first macro.
    Same as -> except will short-circuit with nil when it encounters a nil value."
      (if (= 0 (select "#" ...))


@@ 3393,7 3775,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
                   (-?> ,el ,(unpack els))
                   ,tmp)))))
    
    (fn -?>> [val ...]
    (fn -?>>* [val ...]
      "Nil-safe thread-last macro.
    Same as ->> except will short-circuit with nil when it encounters a nil value."
      (if (= 0 (select "#" ...))


@@ 3408,7 3790,15 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
                   (-?>> ,el ,(unpack els))
                   ,tmp)))))
    
    (fn doto [val ...]
    (fn ?dot [tbl k ...]
      "Nil-safe table look up.
    Same as . (dot), except will short-circuit with nil when it encounters
    a nil value in any of subsequent keys."
      (if (= nil k) tbl
          `(let [res# (. ,tbl ,k)]
             (and res# (?. res# ,...)))))
    
    (fn doto* [val ...]
      "Evaluates val and splices it into the first argument of subsequent forms."
      (let [name (gensym)
            form `(let [,name ,val])]


@@ 3418,13 3808,13 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
        (table.insert form name)
        form))
    
    (fn when [condition body1 ...]
    (fn when* [condition body1 ...]
      "Evaluate body for side-effects only when condition is truthy."
      (assert body1 "expected body")
      `(if ,condition
           (do ,body1 ,...)))
    
    (fn with-open [closable-bindings ...]
    (fn with-open* [closable-bindings ...]
      "Like `let`, but invokes (v:close) on each binding after evaluating the body.
    The body is evaluated inside `xpcall` so that bound values will be closed upon
    encountering an error before propagating it."


@@ 3439,13 3829,57 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
        `(let ,closable-bindings ,closer
              (close-handlers# (xpcall ,bodyfn ,traceback)))))
    
    (fn partial [f ...]
    (fn collect* [iter-tbl key-value-expr ...]
      "Returns a table made by running an iterator and evaluating an expression
    that returns key-value pairs to be inserted sequentially into the table.
    This can be thought of as a \"table comprehension\". The provided key-value
    expression must return either 2 values, or nil.
    
    For example,
      (collect [k v (pairs {:apple \"red\" :orange \"orange\"})]
        (values v k))
    returns
      {:red \"apple\" :orange \"orange\"}"
      (assert (and (sequence? iter-tbl) (>= (length iter-tbl) 2))
              "expected iterator binding table")
      (assert (not= nil key-value-expr)
              "expected key-value expression")
      (assert (= nil ...)
              "expected exactly one body expression. Wrap multiple expressions with do")
      `(let [tbl# {}]
         (each ,iter-tbl
           (match ,key-value-expr
             (k# v#) (tset tbl# k# v#)))
         tbl#))
    
    (fn icollect* [iter-tbl value-expr ...]
      "Returns a sequential table made by running an iterator and evaluating an
    expression that returns values to be inserted sequentially into the table.
    This can be thought of as a \"list comprehension\".
    
    For example,
      (icollect [_ v (ipairs [1 2 3 4 5])] (when (> v 2) (* v v)))
    returns
      [9 16 25]"
      (assert (and (sequence? iter-tbl) (>= (length iter-tbl) 2))
              "expected iterator binding table")
      (assert (not= nil value-expr)
              "expected table value expression")
      (assert (= nil ...)
              "expected exactly one body expression. Wrap multiple expressions with do")
      `(let [tbl# []]
         (each ,iter-tbl
           (tset tbl# (+ (length tbl#) 1) ,value-expr))
         tbl#))
    
    (fn partial* [f ...]
      "Returns a function with all arguments partially applied to f."
      (assert f "expected a function to partially apply")
      (let [body (list f ...)]
        (table.insert body _VARARG)
        `(fn [,_VARARG] ,body)))
    
    (fn pick-args [n f]
    (fn pick-args* [n f]
      "Creates a function of arity n that applies its arguments to f.
    
    For example,


@@ 3453,12 3887,12 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
    expands to
      (fn [_0_ _1_] (func _0_ _1_))"
      (assert (and (= (type n) :number) (= n (math.floor n)) (>= n 0))
              "Expected n to be an integer literal >= 0.")
              (.. "Expected n to be an integer literal >= 0, got " (tostring n)))
      (let [bindings []]
        (for [i 1 n] (tset bindings i (gensym)))
        `(fn ,bindings (,f ,(unpack bindings)))))
    
    (fn pick-values [n ...]
    (fn pick-values* [n ...]
      "Like the `values` special, but emits exactly n values.
    
    For example,


@@ 3467,14 3901,14 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
      (let [(_0_ _1_) ...]
        (values _0_ _1_))"
      (assert (and (= :number (type n)) (>= n 0) (= n (math.floor n)))
              "Expected n to be an integer >= 0")
              (.. "Expected n to be an integer >= 0, got " (tostring n)))
      (let [let-syms   (list)
            let-values (if (= 1 (select :# ...)) ... `(values ,...))]
        (for [i 1 n] (table.insert let-syms (gensym)))
        (if (= n 0) `(values)
            `(let [,let-syms ,let-values] (values ,(unpack let-syms))))))
    
    (fn lambda [...]
    (fn lambda* [...]
      "Function literal with arity checking.
    Will throw an exception if a declared argument is passed in as nil, unless
    that argument name begins with ?."


@@ 3506,20 3940,19 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
            (table.insert args (sym :nil)))
        `(fn ,(unpack args))))
    
    (fn macro [name ...]
    (fn macro* [name ...]
      "Define a single macro."
      (assert (sym? name) "expected symbol for macro name")
      (local args [...])
      `(macros { ,(tostring name) (fn ,(unpack args))}))
    
    (fn macrodebug [form return?]
    (fn macrodebug* [form return?]
      "Print the resulting form after performing macroexpansion.
    With a second argument, returns expanded form as a string instead of printing."
      (let [(ok view) (pcall require :fennelview)
            handle (if return? `do `print)]
        `(,handle ,((if ok view tostring) (macroexpand form _SCOPE)))))
      (let [handle (if return? `do `print)]
        `(,handle ,(view (macroexpand form _SCOPE)))))
    
    (fn import-macros [binding1 module-name1 ...]
    (fn import-macros* [binding1 module-name1 ...]
      "Binds a table of macros from each macro module according to a binding form.
    Each binding form can be either a symbol or a k/v destructuring table.
    Example:


@@ 3533,10 3966,8 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
              ;; to bring in macro module. after that, we just copy the
              ;; macros from subscope to scope.
              scope (get-scope)
              subscope (fennel.scope scope)
              opts {:scope subscope}]
          (each [k v (pairs  utils.root.options)] (tset opts k v))
          (fennel.compile-string (string.format "(require-macros %q)" modname) opts)
              subscope (fennel.scope scope)]
          (_SPECIALS.require-macros `(require-macros ,modname) subscope {} ast)
          (if (sym? binding)
              ;; bind whole table of macros to table bound to symbol
              (do (tset scope.macros (. binding 1) {})


@@ 3547,7 3978,8 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
              (table? binding)
              (each [macro-name [import-key] (pairs binding)]
                (assert (= :function (type (. subscope.macros macro-name)))
                        (.. "macro " macro-name " not found in module " modname))
                        (.. "macro " macro-name " not found in module "
                            (tostring modname)))
                (tset scope.macros import-key (. subscope.macros macro-name))))))
      nil)
    


@@ 3568,12 4000,12 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
      (let [condition `(and (= (type ,val) :table))
            bindings []]
        (each [k pat (pairs pattern)]
          (if (and (sym? pat) (= "&" (tostring pat)))
          (if (= pat `&)
              (do (assert (not (. pattern (+ k 2)))
                          "expected rest argument before last parameter")
                  (table.insert bindings (. pattern (+ k 1)))
                  (table.insert bindings [`(select ,k ((or _G.unpack
                                                           table.unpack)
                  (table.insert bindings [`(select ,k ((or table.unpack
                                                           _G.unpack)
                                                       ,val))]))
              (and (= :number (type k))
                   (= "&" (tostring (. pattern (- k 1)))))


@@ 3612,7 4044,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
                          true `(not= ,(sym :nil) ,val))
                      [pattern val]))
            ;; guard clause
            (and (list? pattern) (sym? (. pattern 2)) (= :? (tostring (. pattern 2))))
            (and (list? pattern) (= (. pattern 2) `?))
            (let [(pcondition bindings) (match-pattern vals (. pattern 1)
                                                       unifications)
                  condition `(and ,pcondition)]


@@ 3652,8 4084,10 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
                    (tset syms valnum (gensym))))))
        syms))
    
    (fn match [val ...]
      "Perform pattern matching on val. See reference for details."
    (fn match* [val ...]
      ;; Old implementation of match macro, which doesn't directly support
      ;; `where' and `or'. New syntax is implemented in `match-where',
      ;; which simply generates old syntax and feeds it to `match*'.
      (let [clauses [...]
            vals (match-val-syms clauses)]
        ;; protect against multiple evaluation of the value, bind against as


@@ 3661,12 4095,80 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
        (list `let [vals val]
              (match-condition vals clauses))))
    
    {: -> : ->> : -?> : -?>>
     : doto : when : with-open
     : partial : lambda
     : pick-args : pick-values
     : macro : macrodebug : import-macros
     : match}
    ;; Construction of old match syntax from new syntax
    
    (fn partition-2 [seq]
      ;; Partition `seq` by 2.
      ;; If `seq` has odd amount of elements, the last one is dropped.
      ;;
      ;; Input: [1 2 3 4 5]
      ;; Output: [[1 2] [3 4]]
      (let [firsts []
            seconds []
            res []]
        (for [i 1 (length seq) 2]
          (let [first (. seq i)
                second (. seq (+ i 1))]
            (table.insert firsts (if (not= nil first) first 'nil))
            (table.insert seconds (if (not= nil second) second 'nil))))
        (each [i v1 (ipairs firsts)]
          (let [v2 (. seconds i)]
            (if (not= nil v2)
                (table.insert res [v1 v2]))))
        res))
    
    (fn transform-or [[_ & pats] guards]
      ;; Transforms `(or pat pats*)` lists into match `guard` patterns.
      ;;
      ;; (or pat1 pat2), guard => [(pat1 ? guard) (pat2 ? guard)]
      (let [res []]
        (each [_ pat (ipairs pats)]
          (table.insert res (list pat '? (unpack guards))))
        res))
    
    (fn transform-cond [cond]
      ;; Transforms `where` cond into sequence of `match` guards.
      ;;
      ;; pat => [pat]
      ;; (where pat guard) => [(pat ? guard)]
      ;; (where (or pat1 pat2) guard) => [(pat1 ? guard) (pat2 ? guard)]
      (if (and (list? cond) (= (. cond 1) `where))
          (let [second (. cond 2)]
            (if (and (list? second) (= (. second 1) `or))
                (transform-or second [(unpack cond 3)])
                :else
                [(list second '? (unpack cond 3))]))
          :else
          [cond]))
    
    (fn match-where [val ...]
      "Perform pattern matching on val. See reference for details.
    
    Syntax:
    
    (match data-expression
      pattern body
      (where pattern guard guards*) body
      (where (or pattern patterns*) guard guards*) body)"
      (let [conds-bodies (partition-2 [...])
            else-branch (if (not= 0 (% (select :# ...) 2))
                            (select (select :# ...) ...))
            match-body []]
        (each [_ [cond body] (ipairs conds-bodies)]
          (each [_ cond (ipairs (transform-cond cond))]
            (table.insert match-body cond)
            (table.insert match-body body)))
        (if else-branch
            (table.insert match-body else-branch))
        (match* val (unpack match-body))))
    
    {:-> ->* :->> ->>* :-?> -?>* :-?>> -?>>* :?. ?dot
     :doto doto* :when when* :with-open with-open*
     :collect collect* :icollect icollect*
     :partial partial* :lambda lambda*
     :pick-args pick-args* :pick-values pick-values*
     :macro macro* :macrodebug macrodebug* :import-macros import-macros*
     :match match-where}
    ]===]
    local module_name = "fennel.macros"
    local _ = nil


@@ 3678,7 4180,6 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
    local env = nil
    do
      local _1_0 = specials["make-compiler-env"](nil, compiler.scopes.compiler, {})
      _1_0["require"] = require
      _1_0["utils"] = utils
      _1_0["fennel"] = mod
      env = _1_0


@@ 3693,8 4194,8 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
  return mod
end
fennel = require("fennel")
local unpack = (_G.unpack or table.unpack)
local help = "\nUsage: fennel [FLAG] [FILE]\n\nRun fennel, a lisp programming language for the Lua runtime.\n\n  --repl                  : Command to launch an interactive repl session\n  --compile FILES         : Command to AOT compile files, writing Lua to stdout\n  --eval SOURCE (-e)      : Command to evaluate source code and print the result\n\n  --no-searcher           : Skip installing package.searchers entry\n  --indent VAL            : Indent compiler output with VAL\n  --add-package-path PATH : Add PATH to package.path for finding Lua modules\n  --add-fennel-path  PATH : Add PATH to fennel.path for finding Fennel modules\n  --globals G1[,G2...]    : Allow these globals in addition to standard ones\n  --globals-only G1[,G2]  : Same as above, but exclude standard ones\n  --require-as-include    : Inline required modules in the output\n  --metadata              : Enable function metadata, even in compiled output\n  --no-metadata           : Disable function metadata, even in REPL\n  --correlate             : Make Lua output line numbers match Fennel input\n  --load FILE (-l)        : Load the specified FILE before executing the command\n  --lua LUA_EXE           : Run in a child process with LUA_EXE (experimental)\n  --no-fennelrc           : Skip loading ~/.fennelrc when launching repl\n  --plugin FILE           : Activate the compiler plugin in FILE\n  --compile-binary FILE\n      OUT LUA_LIB LUA_DIR : Compile FILE to standalone binary OUT (experimental)\n  --compile-binary --help : Display further help for compiling binaries\n  --no-compiler-sandbox   : Do not limit compiler environment to minimal sandbox\n\n  --help (-h)             : Display this text\n  --version (-v)          : Show version\n\n  Globals are not checked when doing AOT (ahead-of-time) compilation unless\n  the --globals-only flag is provided.\n\n  Metadata is typically considered a development feature and is not recommended\n  for production. It is used for docstrings and enabled by default in the REPL.\n\n  When not given a command, runs the file given as the first argument.\n  When given neither command nor file, launches a repl.\n\n  If ~/.fennelrc exists, loads it before launching a repl."
local unpack = (table.unpack or _G.unpack)
local help = "\nUsage: fennel [FLAG] [FILE]\n\nRun fennel, a lisp programming language for the Lua runtime.\n\n  --repl                  : Command to launch an interactive repl session\n  --compile FILES         : Command to AOT compile files, writing Lua to stdout\n  --eval SOURCE (-e)      : Command to evaluate source code and print the result\n\n  --no-searcher           : Skip installing package.searchers entry\n  --indent VAL            : Indent compiler output with VAL\n  --add-package-path PATH : Add PATH to package.path for finding Lua modules\n  --add-fennel-path  PATH : Add PATH to fennel.path for finding Fennel modules\n  --globals G1[,G2...]    : Allow these globals in addition to standard ones\n  --globals-only G1[,G2]  : Same as above, but exclude standard ones\n  --require-as-include    : Inline required modules in the output\n  --metadata              : Enable function metadata, even in compiled output\n  --no-metadata           : Disable function metadata, even in REPL\n  --correlate             : Make Lua output line numbers match Fennel input\n  --load FILE (-l)        : Load the specified FILE before executing the command\n  --lua LUA_EXE           : Run in a child process with LUA_EXE\n  --no-fennelrc           : Skip loading ~/.fennelrc when launching repl\n  --plugin FILE           : Activate the compiler plugin in FILE\n  --compile-binary FILE\n      OUT LUA_LIB LUA_DIR : Compile FILE to standalone binary OUT\n  --compile-binary --help : Display further help for compiling binaries\n  --no-compiler-sandbox   : Do not limit compiler environment to minimal sandbox\n\n  --help (-h)             : Display this text\n  --version (-v)          : Show version\n\n  Globals are not checked when doing AOT (ahead-of-time) compilation unless\n  the --globals-only flag is provided.\n\n  Metadata is typically considered a development feature and is not recommended\n  for production. It is used for docstrings and enabled by default in the REPL.\n\n  When not given a command, runs the file given as the first argument.\n  When given neither command nor file, launches a repl.\n\n  If ~/.fennelrc exists, loads it before launching a repl."
local options = {plugins = {}}
local function dosafely(f, ...)
  local args = {...}


@@ 3797,7 4298,7 @@ for i = #arg, 1, -1 do
    options["compiler-env"] = _G
    table.remove(arg, i)
  elseif (_0_0 == "--plugin") then
    local plugin = fennel.dofile(table.remove(arg, (i + 1)), {env = "_COMPILER"})
    local plugin = fennel.dofile(table.remove(arg, (i + 1)), {env = "_COMPILER", useMetadata = true})
    table.insert(options.plugins, 1, plugin)
    table.remove(arg, i)
  end


@@ 3865,7 4366,7 @@ end
local function repl()
  local readline = try_readline(pcall(require, "readline"))
  searcher_opts.useMetadata = (false ~= options.useMetadata)
  options.pp = require("fennelview")
  options.pp = require("fennel.view")
  if (false ~= options.fennelrc) then
    load_initfile()
  end