garden/fennel.lua

-- SPDX-License-Identifier: MIT
-- SPDX-FileCopyrightText: Calvin Rose and contributors
package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
  local utils = require("fennel.utils")
  local parser = require("fennel.parser")
  local compiler = require("fennel.compiler")
  local specials = require("fennel.specials")
  local view = require("fennel.view")
  local unpack = (table.unpack or _G.unpack)
  local depth = 0
  local function prompt_for(top_3f)
    if top_3f then
      return (string.rep(">", (depth + 1)) .. " ")
    else
      return (string.rep(".", (depth + 1)) .. " ")
    end
  end
  local function default_read_chunk(parser_state)
    io.write(prompt_for((0 == parser_state["stack-size"])))
    io.flush()
    local input = io.read()
    return (input and (input .. "\n"))
  end
  local function default_on_values(xs)
    io.write(table.concat(xs, "\9"))
    return io.write("\n")
  end
  local function default_on_error(errtype, err, lua_source)
    local function _612_()
      local _611_0 = errtype
      if (_611_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 (_611_0 == "Runtime") then
        return (compiler.traceback(tostring(err), 4) .. "\n")
      else
        local _ = _611_0
        return ("%s error: %s\n"):format(errtype, tostring(err))
      end
    end
    return io.write(_612_())
  end
  local function splice_save_locals(env, lua_source, scope)
    local saves = nil
    do
      local tbl_17_ = {}
      local i_18_ = #tbl_17_
      for name in pairs(env.___replLocals___) do
        local val_19_ = ("local %s = ___replLocals___[%q]"):format((scope.manglings[name] or name), name)
        if (nil ~= val_19_) then
          i_18_ = (i_18_ + 1)
          tbl_17_[i_18_] = val_19_
        end
      end
      saves = tbl_17_
    end
    local binds = nil
    do
      local tbl_17_ = {}
      local i_18_ = #tbl_17_
      for raw, name in pairs(scope.manglings) do
        local val_19_ = nil
        if not scope.gensyms[name] then
          val_19_ = ("___replLocals___[%q] = %s"):format(raw, name)
        else
        val_19_ = nil
        end
        if (nil ~= val_19_) then
          i_18_ = (i_18_ + 1)
          tbl_17_[i_18_] = val_19_
        end
      end
      binds = tbl_17_
    end
    local gap = nil
    if lua_source:find("\n") then
      gap = "\n"
    else
      gap = " "
    end
    local function _618_()
      if next(saves) then
        return (table.concat(saves, " ") .. gap)
      else
        return ""
      end
    end
    local function _621_()
      local _619_0, _620_0 = lua_source:match("^(.*)[\n ](return .*)$")
      if ((nil ~= _619_0) and (nil ~= _620_0)) then
        local body = _619_0
        local _return = _620_0
        return (body .. gap .. table.concat(binds, " ") .. gap .. _return)
      else
        local _ = _619_0
        return lua_source
      end
    end
    return (_618_() .. _621_())
  end
  local function completer(env, scope, text)
    local max_items = 2000
    local seen = {}
    local matches = {}
    local input_fragment = text:gsub(".*[%s)(]+", "")
    local stop_looking_3f = false
    local function add_partials(input, tbl, prefix)
      local scope_first_3f = ((tbl == env) or (tbl == env.___replLocals___))
      local tbl_17_ = matches
      local i_18_ = #tbl_17_
      local function _623_()
        if scope_first_3f then
          return scope.manglings
        else
          return tbl
        end
      end
      for k, is_mangled in utils.allpairs(_623_()) do
        if (max_items <= #matches) then break end
        local val_19_ = nil
        do
          local lookup_k = nil
          if scope_first_3f then
            lookup_k = is_mangled
          else
            lookup_k = k
          end
          if ((type(k) == "string") and (input == k:sub(0, #input)) and not seen[k] and ((":" ~= prefix:sub(-1)) or ("function" == type(tbl[lookup_k])))) then
            seen[k] = true
            val_19_ = (prefix .. k)
          else
          val_19_ = nil
          end
        end
        if (nil ~= val_19_) then
          i_18_ = (i_18_ + 1)
          tbl_17_[i_18_] = val_19_
        end
      end
      return tbl_17_
    end
    local function descend(input, tbl, prefix, add_matches, method_3f)
      local splitter = nil
      if method_3f then
        splitter = "^([^:]+):(.*)"
      else
        splitter = "^([^.]+)%.(.*)"
      end
      local head, tail = input:match(splitter)
      local raw_head = (scope.manglings[head] or head)
      if (type(tbl[raw_head]) == "table") then
        stop_looking_3f = true
        if method_3f then
          return add_partials(tail, tbl[raw_head], (prefix .. head .. ":"))
        else
          return add_matches(tail, tbl[raw_head], (prefix .. head))
        end
      end
    end
    local function add_matches(input, tbl, prefix)
      local prefix0 = nil
      if prefix then
        prefix0 = (prefix .. ".")
      else
        prefix0 = ""
      end
      if (not input:find("%.") and input:find(":")) then
        return descend(input, tbl, prefix0, add_matches, true)
      elseif not input:find("%.") then
        return add_partials(input, tbl, prefix0)
      else
        return descend(input, tbl, prefix0, add_matches, false)
      end
    end
    for _, source in ipairs({scope.specials, scope.macros, (env.___replLocals___ or {}), env, env._G}) do
      if stop_looking_3f then break end
      add_matches(input_fragment, source)
    end
    return matches
  end
  local commands = {}
  local function command_3f(input)
    return input:match("^%s*,")
  end
  local function command_docs()
    local _632_
    do
      local tbl_17_ = {}
      local i_18_ = #tbl_17_
      for name, f in pairs(commands) do
        local val_19_ = ("  ,%s - %s"):format(name, ((compiler.metadata):get(f, "fnl/docstring") or "undocumented"))
        if (nil ~= val_19_) then
          i_18_ = (i_18_ + 1)
          tbl_17_[i_18_] = val_19_
        end
      end
      _632_ = tbl_17_
    end
    return table.concat(_632_, "\n")
  end
  commands.help = function(_, _0, on_values)
    return on_values({("Welcome to Fennel.\nThis is the REPL where you can enter code to be evaluated.\nYou can also run these repl commands:\n\n" .. command_docs() .. "\n  ,return FORM - Evaluate FORM and return its value to the REPL's caller.\n  ,exit - Leave the repl.\n\nUse ,doc something to see descriptions for individual macros and special forms.\nValues from previous inputs are kept in *1, *2, and *3.\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 _634_0, _635_0 = pcall(specials["load-code"]("return require(...)", env), module_name)
    if ((_634_0 == true) and (nil ~= _635_0)) then
      local old = _635_0
      local _ = nil
      package.loaded[module_name] = nil
      _ = nil
      local ok, new = pcall(require, module_name)
      local new0 = nil
      if not ok then
        on_values({new})
        new0 = old
      else
        new0 = new
      end
      specials["macro-loaded"][module_name] = nil
      if ((type(old) == "table") and (type(new0) == "table")) then
        for k, v in pairs(new0) do
          old[k] = v
        end
        for k in pairs(old) do
          if (nil == new0[k]) then
            old[k] = nil
          end
        end
        package.loaded[module_name] = old
      end
      return on_values({"ok"})
    elseif ((_634_0 == false) and (nil ~= _635_0)) then
      local msg = _635_0
      if msg:match("loop or previous error loading module") then
        package.loaded[module_name] = nil
        return reload(module_name, env, on_values, on_error)
      elseif specials["macro-loaded"][module_name] then
        specials["macro-loaded"][module_name] = nil
        return nil
      else
        local function _640_()
          local _639_0 = msg:gsub("\n.*", "")
          return _639_0
        end
        return on_error("Runtime", _640_())
      end
    end
  end
  local function run_command(read, on_error, f)
    local _643_0, _644_0, _645_0 = pcall(read)
    if ((_643_0 == true) and (_644_0 == true) and (nil ~= _645_0)) then
      local val = _645_0
      local _646_0, _647_0 = pcall(f, val)
      if ((_646_0 == false) and (nil ~= _647_0)) then
        local msg = _647_0
        return on_error("Runtime", msg)
      end
    elseif (_643_0 == false) then
      return on_error("Parse", "Couldn't parse input.")
    end
  end
  commands.reload = function(env, read, on_values, on_error)
    local function _650_(_241)
      return reload(tostring(_241), env, on_values, on_error)
    end
    return run_command(read, on_error, _650_)
  end
  do end (compiler.metadata):set(commands.reload, "fnl/docstring", "Reload the specified module.")
  commands.reset = function(env, _, on_values)
    env.___replLocals___ = {}
    return on_values({"ok"})
  end
  do end (compiler.metadata):set(commands.reset, "fnl/docstring", "Erase all repl-local scope.")
  commands.complete = function(env, read, on_values, on_error, scope, chars)
    local function _651_()
      return on_values(completer(env, scope, table.concat(chars):gsub(",complete +", ""):sub(1, -2)))
    end
    return run_command(read, on_error, _651_)
  end
  do end (compiler.metadata):set(commands.complete, "fnl/docstring", "Print all possible completions for a given input symbol.")
  local function apropos_2a(pattern, tbl, prefix, seen, names)
    for name, subtbl in pairs(tbl) do
      if (("string" == type(name)) and (package ~= subtbl)) then
        local _652_0 = type(subtbl)
        if (_652_0 == "function") then
          if ((prefix .. name)):match(pattern) then
            table.insert(names, (prefix .. name))
          end
        elseif (_652_0 == "table") then
          if not seen[subtbl] then
            local _654_
            do
              seen[subtbl] = true
              _654_ = seen
            end
            apropos_2a(pattern, subtbl, (prefix .. name:gsub("%.", "/") .. "."), _654_, names)
          end
        end
      end
    end
    return names
  end
  local function apropos(pattern)
    local names = apropos_2a(pattern, package.loaded, "", {}, {})
    local tbl_17_ = {}
    local i_18_ = #tbl_17_
    for _, name in ipairs(names) do
      local val_19_ = name:gsub("^_G%.", "")
      if (nil ~= val_19_) then
        i_18_ = (i_18_ + 1)
        tbl_17_[i_18_] = val_19_
      end
    end
    return tbl_17_
  end
  commands.apropos = function(_env, read, on_values, on_error, _scope)
    local function _659_(_241)
      return on_values(apropos(tostring(_241)))
    end
    return run_command(read, on_error, _659_)
  end
  do end (compiler.metadata):set(commands.apropos, "fnl/docstring", "Print all functions matching a pattern in all loaded modules.")
  local function apropos_follow_path(path)
    local paths = nil
    do
      local tbl_17_ = {}
      local i_18_ = #tbl_17_
      for p in path:gmatch("[^%.]+") do
        local val_19_ = p
        if (nil ~= val_19_) then
          i_18_ = (i_18_ + 1)
          tbl_17_[i_18_] = val_19_
        end
      end
      paths = tbl_17_
    end
    local tgt = package.loaded
    for _, path0 in ipairs(paths) do
      if (nil == tgt) then break end
      local _662_
      do
        local _661_0 = path0:gsub("%/", ".")
        _662_ = _661_0
      end
      tgt = tgt[_662_]
    end
    return tgt
  end
  local function apropos_doc(pattern)
    local tbl_17_ = {}
    local i_18_ = #tbl_17_
    for _, path in ipairs(apropos(".*")) do
      local val_19_ = nil
      do
        local tgt = apropos_follow_path(path)
        if ("function" == type(tgt)) then
          local _663_0 = (compiler.metadata):get(tgt, "fnl/docstring")
          if (nil ~= _663_0) then
            local docstr = _663_0
            val_19_ = (docstr:match(pattern) and path)
          else
          val_19_ = nil
          end
        else
        val_19_ = nil
        end
      end
      if (nil ~= val_19_) then
        i_18_ = (i_18_ + 1)
        tbl_17_[i_18_] = val_19_
      end
    end
    return tbl_17_
  end
  commands["apropos-doc"] = function(_env, read, on_values, on_error, _scope)
    local function _667_(_241)
      return on_values(apropos_doc(tostring(_241)))
    end
    return run_command(read, on_error, _667_)
  end
  do end (compiler.metadata):set(commands["apropos-doc"], "fnl/docstring", "Print all functions that match the pattern in their docs")
  local function apropos_show_docs(on_values, pattern)
    for _, path in ipairs(apropos(pattern)) do
      local tgt = apropos_follow_path(path)
      if (("function" == type(tgt)) and (compiler.metadata):get(tgt, "fnl/docstring")) then
        on_values({specials.doc(tgt, path)})
        on_values({})
      end
    end
    return nil
  end
  commands["apropos-show-docs"] = function(_env, read, on_values, on_error)
    local function _669_(_241)
      return apropos_show_docs(on_values, tostring(_241))
    end
    return run_command(read, on_error, _669_)
  end
  do end (compiler.metadata):set(commands["apropos-show-docs"], "fnl/docstring", "Print all documentations matching a pattern in function name")
  local function resolve(identifier, _670_0, scope)
    local _671_ = _670_0
    local env = _671_
    local ___replLocals___ = _671_["___replLocals___"]
    local e = nil
    local function _672_(_241, _242)
      return (___replLocals___[scope.unmanglings[_242]] or env[_242])
    end
    e = setmetatable({}, {__index = _672_})
    local function _673_(...)
      local _674_0, _675_0 = ...
      if ((_674_0 == true) and (nil ~= _675_0)) then
        local code = _675_0
        local function _676_(...)
          local _677_0, _678_0 = ...
          if ((_677_0 == true) and (nil ~= _678_0)) then
            local val = _678_0
            return val
          else
            local _ = _677_0
            return nil
          end
        end
        return _676_(pcall(specials["load-code"](code, e)))
      else
        local _ = _674_0
        return nil
      end
    end
    return _673_(pcall(compiler["compile-string"], tostring(identifier), {scope = scope}))
  end
  commands.find = function(env, read, on_values, on_error, scope)
    local function _681_(_241)
      local _682_0 = nil
      do
        local _683_0 = utils["sym?"](_241)
        if (nil ~= _683_0) then
          local _684_0 = resolve(_683_0, env, scope)
          if (nil ~= _684_0) then
            _682_0 = debug.getinfo(_684_0)
          else
            _682_0 = _684_0
          end
        else
          _682_0 = _683_0
        end
      end
      if ((_G.type(_682_0) == "table") and (nil ~= _682_0.linedefined) and (nil ~= _682_0.short_src) and (nil ~= _682_0.source) and (_682_0.what == "Lua")) then
        local line = _682_0.linedefined
        local src = _682_0.short_src
        local source = _682_0.source
        local fnlsrc = nil
        do
          local _687_0 = compiler.sourcemap
          if (nil ~= _687_0) then
            _687_0 = _687_0[source]
          end
          if (nil ~= _687_0) then
            _687_0 = _687_0[line]
          end
          if (nil ~= _687_0) then
            _687_0 = _687_0[2]
          end
          fnlsrc = _687_0
        end
        return on_values({string.format("%s:%s", src, (fnlsrc or line))})
      elseif (_682_0 == nil) then
        return on_error("Repl", "Unknown value")
      else
        local _ = _682_0
        return on_error("Repl", "No source info")
      end
    end
    return run_command(read, on_error, _681_)
  end
  do end (compiler.metadata):set(commands.find, "fnl/docstring", "Print the filename and line number for a given function")
  commands.doc = function(env, read, on_values, on_error, scope)
    local function _692_(_241)
      local name = tostring(_241)
      local path = (utils["multi-sym?"](name) or {name})
      local ok_3f, target = nil, nil
      local function _693_()
        return (utils["get-in"](scope.specials, path) or utils["get-in"](scope.macros, path) or resolve(name, env, scope))
      end
      ok_3f, target = pcall(_693_)
      if ok_3f then
        return on_values({specials.doc(target, name)})
      else
        return on_error("Repl", ("Could not find " .. name .. " for docs."))
      end
    end
    return run_command(read, on_error, _692_)
  end
  do end (compiler.metadata):set(commands.doc, "fnl/docstring", "Print the docstring and arglist for a function, macro, or special form.")
  commands.compile = function(env, read, on_values, on_error, scope)
    local function _695_(_241)
      local allowedGlobals = specials["current-global-names"](env)
      local ok_3f, result = pcall(compiler.compile, _241, {allowedGlobals = allowedGlobals, env = env, scope = scope})
      if ok_3f then
        return on_values({result})
      else
        return on_error("Repl", ("Error compiling expression: " .. result))
      end
    end
    return run_command(read, on_error, _695_)
  end
  do end (compiler.metadata):set(commands.compile, "fnl/docstring", "compiles the expression into lua and prints the result.")
  local function load_plugin_commands(plugins)
    for i = #(plugins or {}), 1, -1 do
      for name, f in pairs(plugins[i]) do
        local _697_0 = name:match("^repl%-command%-(.*)")
        if (nil ~= _697_0) then
          local cmd_name = _697_0
          commands[cmd_name] = f
        end
      end
    end
    return nil
  end
  local function run_command_loop(input, read, loop, env, on_values, on_error, scope, chars)
    local command_name = input:match(",([^%s/]+)")
    do
      local _699_0 = commands[command_name]
      if (nil ~= _699_0) then
        local command = _699_0
        command(env, read, on_values, on_error, scope, chars)
      else
        local _ = _699_0
        if ((command_name ~= "exit") and (command_name ~= "return")) then
          on_values({"Unknown command", command_name})
        end
      end
    end
    if ("exit" ~= command_name) then
      return loop((command_name == "return"))
    end
  end
  local function try_readline_21(opts, ok, readline)
    if ok then
      if readline.set_readline_name then
        readline.set_readline_name("fennel")
      end
      readline.set_options({histfile = "", keeplines = 1000})
      opts.readChunk = function(parser_state)
        local prompt = nil
        if (0 < parser_state["stack-size"]) then
          prompt = ".. "
        else
          prompt = ">> "
        end
        local str = readline.readline(prompt)
        if str then
          return (str .. "\n")
        end
      end
      local completer0 = nil
      opts.registerCompleter = function(repl_completer)
        completer0 = repl_completer
        return nil
      end
      local function repl_completer(text, from, to)
        if completer0 then
          readline.set_completion_append_character("")
          return completer0(text:sub(from, to))
        else
          return {}
        end
      end
      readline.set_complete_function(repl_completer)
      return readline
    end
  end
  local function should_use_readline_3f(opts)
    return (("dumb" ~= os.getenv("TERM")) and not opts.readChunk and not opts.registerCompleter)
  end
  local function repl(_3foptions)
    local old_root_options = utils.root.options
    local _708_ = utils.copy(_3foptions)
    local opts = _708_
    local _3ffennelrc = _708_["fennelrc"]
    local _ = nil
    opts.fennelrc = nil
    _ = nil
    local readline = (should_use_readline_3f(opts) and try_readline_21(opts, pcall(require, "readline")))
    local _0 = nil
    if _3ffennelrc then
      _0 = _3ffennelrc()
    else
    _0 = nil
    end
    local env = specials["wrap-env"]((opts.env or rawget(_G, "_ENV") or _G))
    local callbacks = {env = env, onError = (opts.onError or default_on_error), onValues = (opts.onValues or default_on_values), pp = (opts.pp or view), readChunk = (opts.readChunk or default_read_chunk)}
    local save_locals_3f = (opts.saveLocals ~= false)
    local byte_stream, clear_stream = nil, nil
    local function _710_(_241)
      return callbacks.readChunk(_241)
    end
    byte_stream, clear_stream = parser.granulate(_710_)
    local chars = {}
    local read, reset = nil, nil
    local function _711_(parser_state)
      local b = byte_stream(parser_state)
      if b then
        table.insert(chars, string.char(b))
      end
      return b
    end
    read, reset = parser.parser(_711_)
    depth = (depth + 1)
    if opts.message then
      callbacks.onValues({opts.message})
    end
    env.___repl___ = callbacks
    opts.env, opts.scope = env, compiler["make-scope"]()
    opts.useMetadata = (opts.useMetadata ~= false)
    if (opts.allowedGlobals == nil) then
      opts.allowedGlobals = specials["current-global-names"](env)
    end
    if opts.init then
      opts.init(opts, depth)
    end
    if opts.registerCompleter then
      local function _717_()
        local _716_0 = opts.scope
        local function _718_(...)
          return completer(env, _716_0, ...)
        end
        return _718_
      end
      opts.registerCompleter(_717_())
    end
    load_plugin_commands(opts.plugins)
    if save_locals_3f then
      local function newindex(t, k, v)
        if opts.scope.manglings[k] then
          return rawset(t, k, v)
        end
      end
      env.___replLocals___ = setmetatable({}, {__newindex = newindex})
    end
    local function print_values(...)
      local vals = {...}
      local out = {}
      local pp = callbacks.pp
      env._, env.__ = vals[1], vals
      for i = 1, select("#", ...) do
        table.insert(out, pp(vals[i]))
      end
      return callbacks.onValues(out)
    end
    local function save_value(...)
      env.___replLocals___["*3"] = env.___replLocals___["*2"]
      env.___replLocals___["*2"] = env.___replLocals___["*1"]
      env.___replLocals___["*1"] = ...
      return ...
    end
    opts.scope.manglings["*1"], opts.scope.unmanglings._1 = "_1", "*1"
    opts.scope.manglings["*2"], opts.scope.unmanglings._2 = "_2", "*2"
    opts.scope.manglings["*3"], opts.scope.unmanglings._3 = "_3", "*3"
    local function loop(exit_next_3f)
      for k in pairs(chars) do
        chars[k] = nil
      end
      reset()
      local ok, parser_not_eof_3f, form = pcall(read)
      local src_string = table.concat(chars)
      local readline_not_eof_3f = (not readline or (src_string ~= "(null)"))
      local not_eof_3f = (readline_not_eof_3f and parser_not_eof_3f)
      if not ok then
        callbacks.onError("Parse", not_eof_3f)
        clear_stream()
        return loop()
      elseif command_3f(src_string) then
        return run_command_loop(src_string, read, loop, env, callbacks.onValues, callbacks.onError, opts.scope, chars)
      else
        if not_eof_3f then
          local function _722_(...)
            local _723_0, _724_0 = ...
            if ((_723_0 == true) and (nil ~= _724_0)) then
              local src = _724_0
              local function _725_(...)
                local _726_0, _727_0 = ...
                if ((_726_0 == true) and (nil ~= _727_0)) then
                  local chunk = _727_0
                  local function _728_()
                    return print_values(save_value(chunk()))
                  end
                  local function _729_(...)
                    return callbacks.onError("Runtime", ...)
                  end
                  return xpcall(_728_, _729_)
                elseif ((_726_0 == false) and (nil ~= _727_0)) then
                  local msg = _727_0
                  clear_stream()
                  return callbacks.onError("Compile", msg)
                end
              end
              local function _732_(...)
                local src0 = nil
                if save_locals_3f then
                  src0 = splice_save_locals(env, src, opts.scope)
                else
                  src0 = src
                end
                return pcall(specials["load-code"], src0, env)
              end
              return _725_(_732_(...))
            elseif ((_723_0 == false) and (nil ~= _724_0)) then
              local msg = _724_0
              clear_stream()
              return callbacks.onError("Compile", msg)
            end
          end
          local function _734_()
            opts["source"] = src_string
            return opts
          end
          _722_(pcall(compiler.compile, form, _734_()))
          utils.root.options = old_root_options
          if exit_next_3f then
            return env.___replLocals___["*1"]
          else
            return loop()
          end
        end
      end
    end
    local value = loop()
    depth = (depth - 1)
    if readline then
      readline.save_history()
    end
    if opts.exit then
      opts.exit(opts, depth)
    end
    return value
  end
  return repl
end
package.preload["fennel.specials"] = package.preload["fennel.specials"] or function(...)
  local utils = require("fennel.utils")
  local view = require("fennel.view")
  local parser = require("fennel.parser")
  local compiler = require("fennel.compiler")
  local unpack = (table.unpack or _G.unpack)
  local SPECIALS = compiler.scopes.global.specials
  local function wrap_env(env)
    local function _417_(_, key)
      if utils["string?"](key) then
        return env[compiler["global-unmangling"](key)]
      else
        return env[key]
      end
    end
    local function _419_(_, key, value)
      if utils["string?"](key) then
        env[compiler["global-unmangling"](key)] = value
        return nil
      else
        env[key] = value
        return nil
      end
    end
    local function _421_()
      local function putenv(k, v)
        local _422_
        if utils["string?"](k) then
          _422_ = compiler["global-unmangling"](k)
        else
          _422_ = k
        end
        return _422_, v
      end
      return next, utils.kvmap(env, putenv), nil
    end
    return setmetatable({}, {__index = _417_, __newindex = _419_, __pairs = _421_})
  end
  local function current_global_names(_3fenv)
    local mt = nil
    do
      local _424_0 = getmetatable(_3fenv)
      if ((_G.type(_424_0) == "table") and (nil ~= _424_0.__pairs)) then
        local mtpairs = _424_0.__pairs
        local tbl_14_ = {}
        for k, v in mtpairs(_3fenv) do
          local k_15_, v_16_ = k, v
          if ((k_15_ ~= nil) and (v_16_ ~= nil)) then
            tbl_14_[k_15_] = v_16_
          end
        end
        mt = tbl_14_
      elseif (_424_0 == nil) then
        mt = (_3fenv or _G)
      else
      mt = nil
      end
    end
    return (mt and utils.kvmap(mt, compiler["global-unmangling"]))
  end
  local function load_code(code, _3fenv, _3ffilename)
    local env = (_3fenv or rawget(_G, "_ENV") or _G)
    local _427_0, _428_0 = rawget(_G, "setfenv"), rawget(_G, "loadstring")
    if ((nil ~= _427_0) and (nil ~= _428_0)) then
      local setfenv = _427_0
      local loadstring = _428_0
      local f = assert(loadstring(code, _3ffilename))
      setfenv(f, env)
      return f
    else
      local _ = _427_0
      return assert(load(code, _3ffilename, "t", env))
    end
  end
  local function doc_2a(tgt, name)
    if not tgt then
      return (name .. " not found")
    else
      local docstring = (((compiler.metadata):get(tgt, "fnl/docstring") or "#<undocumented>")):gsub("\n$", ""):gsub("\n", "\n  ")
      local mt = getmetatable(tgt)
      if ((type(tgt) == "function") or ((type(mt) == "table") and (type(mt.__call) == "function"))) then
        local arglist = table.concat(((compiler.metadata):get(tgt, "fnl/arglist") or {"#<unknown-arguments>"}), " ")
        local _430_
        if (0 < #arglist) then
          _430_ = " "
        else
          _430_ = ""
        end
        return string.format("(%s%s%s)\n  %s", name, _430_, arglist, docstring)
      else
        return string.format("%s\n  %s", name, docstring)
      end
    end
  end
  local function doc_special(name, arglist, docstring, body_form_3f)
    compiler.metadata[SPECIALS[name]] = {["fnl/arglist"] = arglist, ["fnl/body-form?"] = body_form_3f, ["fnl/docstring"] = docstring}
    return nil
  end
  local function compile_do(ast, scope, parent, _3fstart)
    local start = (_3fstart or 2)
    local len = #ast
    local sub_scope = compiler["make-scope"](scope)
    for i = start, len do
      compiler.compile1(ast[i], sub_scope, parent, {nval = 0})
    end
    return nil
  end
  SPECIALS["do"] = function(ast, scope, parent, opts, _3fstart, _3fchunk, _3fsub_scope, _3fpre_syms)
    local start = (_3fstart or 2)
    local sub_scope = (_3fsub_scope or compiler["make-scope"](scope))
    local chunk = (_3fchunk or {})
    local len = #ast
    local retexprs = {returned = true}
    local function compile_body(outer_target, outer_tail, outer_retexprs)
      for i = start, len do
        local subopts = {nval = (((i ~= len) and 0) or opts.nval), tail = (((i == len) and outer_tail) or nil), target = (((i == len) and outer_target) or nil)}
        local _ = utils["propagate-options"](opts, subopts)
        local subexprs = compiler.compile1(ast[i], sub_scope, chunk, subopts)
        if (i ~= len) then
          compiler["keep-side-effects"](subexprs, parent, nil, ast[i])
        end
      end
      compiler.emit(parent, chunk, ast)
      compiler.emit(parent, "end", ast)
      utils.hook("do", ast, sub_scope)
      return (outer_retexprs or retexprs)
    end
    if (opts.target or (opts.nval == 0) or opts.tail) then
      compiler.emit(parent, "do", ast)
      return compile_body(opts.target, opts.tail)
    elseif opts.nval then
      local syms = {}
      for i = 1, opts.nval do
        local s = ((_3fpre_syms and _3fpre_syms[i]) or compiler.gensym(scope))
        syms[i] = s
        retexprs[i] = utils.expr(s, "sym")
      end