~technomancy/fnlfmt

87c5ad517ecd75669b0b9ce82da72096a59700c8 — Phil Hagelberg a month ago 0582de3
Support adding line breaks in, not just indentation.
7 files changed, 7180 insertions(+), 36 deletions(-)

M Makefile
M README.md
M cli.fnl
A fennel.lua
A fennelview.fnl
M fnlfmt
M fnlfmt.fnl
M Makefile => Makefile +2 -2
@@ 1,8 1,8 @@
SRC = fnlfmt.fnl cli.fnl test.fnl

fnlfmt: cli.fnl
fnlfmt: cli.fnl fnlfmt.fnl indent.fnl
	echo "#!/usr/bin/env lua" > $@
	fennel --compile --require-as-include $< >> $@
	fennel --require-as-include --compile $< >> $@
	chmod +x fnlfmt

test: fnlfmt ; fennel test.fnl

M README.md => README.md +1 -4
@@ 2,9 2,6 @@

Format your Fennel!

Right now it is strictly for indentation only. It's up to you to keep
your column lengths at 80 or under, so please do that.

## Usage

    $ ./fnlfmt mycode.fnl # prints formatted code to standard out


@@ 23,7 20,7 @@ incorrect indentation in certain situations.

## License

Copyright © 2019 Phil Hagelberg and contributors
Copyright © 2019-2020 Phil Hagelberg and contributors

Released under the terms of the GNU Lesser General Public License
version 3 or later; see the file LICENSE.

M cli.fnl => cli.fnl +21 -9
@@ 1,18 1,30 @@
(local fmt (require :fnlfmt))
(local fennel (require :fennel))
(local view (require :fennelview))
(local {: fnlfmt} (require :fnlfmt))

(fn format [filename]
  (let [f (match filename
            :- io.stdin
            _ (assert (io.open filename :r) "File not found."))
        contents (f:read :*all)]
        parser (-> (f:read :*all)
                   (fennel.stringStream)
                   (fennel.parser))
        out []]
    (f:close)
    (print (fmt.fmt contents))))
    (each [ok? value parser]
      (table.insert out (fnlfmt value)))
    (table.concat out "\n")))

(fn help []
  (print "Usage: fnlfmt FILENAME")
  (print "Prints the reformatted file to standard out."))
  (print "Usage: fnlfmt [--fix] FILENAME")
  (print "With the --fix argument, updates the file in-place; otherwise")
  (print "prints the formatted file to stdout."))

(match arg
  ["--fix" filename] (let [new (format filename)
                           f (assert (io.open filename :w))]
                       (f:write new)
                       (f:close))
  [filename] (print (format filename))
  _ (help))

(if (or (not= (# arg) 1)
        (. {"--help" "-h" "-?" "help"} (. arg 1)))
    (help)
    (format (. arg 1)))

A fennel.lua => fennel.lua +3254 -0
@@ 0,0 1,3254 @@
--[[
Copyright (c) 2016-2019 Calvin Rose and contributors
Permission is hereby granted, free of charge, to any person obtaining a copy of
this software and associated documentation files (the "Software"), to deal in
the Software without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Software, and to permit persons to whom the Software is furnished to do so,
subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
]]

-- Make global variables local.
local setmetatable = setmetatable
local getmetatable = getmetatable
local type = type
local assert = assert
local pairs = pairs
local ipairs = ipairs
local tostring = tostring
local unpack = unpack or table.unpack

--
-- Main Types and support functions
--

local utils = (function()
    -- Like pairs, but gives consistent ordering every time. On 5.1, 5.2, and LuaJIT
    -- pairs is already stable, but on 5.3 every run gives different ordering.
    local function stablepairs(t)
        local keys, succ = {}, {}
        for k in pairs(t) do table.insert(keys, k) end
        table.sort(keys, function(a, b) return tostring(a) < tostring(b) end)
        for i,k in ipairs(keys) do succ[k] = keys[i+1] end
        local function stablenext(tbl, idx)
            if idx == nil then return keys[1], tbl[keys[1]] end
            return succ[idx], tbl[succ[idx]]
        end
        return stablenext, t, nil
    end

    -- Map function f over sequential table t, removing values where f returns nil.
    -- Optionally takes a target table to insert the mapped values into.
    local function map(t, f, out)
        out = out or {}
        if type(f) ~= "function" then local s = f f = function(x) return x[s] end end
        for _,x in ipairs(t) do
            local v = f(x)
            if v then table.insert(out, v) end
        end
        return out
    end

    -- Map function f over key/value table t, similar to above, but it can return a
    -- sequential table if f returns a single value or a k/v table if f returns two.
    -- Optionally takes a target table to insert the mapped values into.
    local function kvmap(t, f, out)
        out = out or {}
        if type(f) ~= "function" then local s = f f = function(x) return x[s] end end
        for k,x in stablepairs(t) do
            local korv, v = f(k, x)
            if korv and not v then table.insert(out, korv) end
            if korv and v then out[korv] = v end
        end
        return out
    end

    -- Returns a shallow copy of its table argument. Returns an empty table on nil.
    local function copy(from)
       local to = {}
       for k, v in pairs(from or {}) do to[k] = v end
       return to
    end

    -- Like pairs, but if the table has an __index metamethod, it will recurisvely
    -- traverse upwards, skipping duplicates, to iterate all inherited properties
    local function allpairs(t)
        assert(type(t) == 'table', 'allpairs expects a table')
        local seen = {}
        local function allpairsNext(_, state)
            local nextState, value = next(t, state)
            if seen[nextState] then
                return allpairsNext(nil, nextState)
            elseif nextState then
                seen[nextState] = true
                return nextState, value
            end
            local meta = getmetatable(t)
            if meta and meta.__index then
                t = meta.__index
                return allpairsNext(t)
            end
        end
        return allpairsNext
    end

    local function deref(self) return self[1] end

    local nilSym -- haven't defined sym yet; create this later

    local function listToString(self, tostring2)
        local safe, max = {}, 0
        for k in pairs(self) do if type(k) == "number" and k>max then max=k end end
        for i=1,max do -- table.maxn was removed from Lua 5.3 for some reason???
            safe[i] = self[i] == nil and nilSym or self[i]
        end
        return '(' .. table.concat(map(safe, tostring2 or tostring), ' ', 1, max) .. ')'
    end

    local SYMBOL_MT = { 'SYMBOL', __tostring = deref, __fennelview = deref }
    local EXPR_MT = { 'EXPR', __tostring = deref }
    local VARARG = setmetatable({ '...' },
        { 'VARARG', __tostring = deref, __fennelview = deref })
    local LIST_MT = { 'LIST', __tostring = listToString, __fennelview = listToString }
    local SEQUENCE_MARKER = { 'SEQUENCE' }

    -- Safely load an environment variable
    local getenv = os and os.getenv or function() return nil end

    local pathTable = {"./?.fnl", "./?/init.fnl"}
    table.insert(pathTable, getenv("FENNEL_PATH"))

    local function debugOn(flag)
        local level = getenv("FENNEL_DEBUG") or ""
        return level == "all" or level:find(flag)
    end

    -- Create a new list. Lists are a compile-time construct in Fennel; they are
    -- represented as tables with a special marker metatable. They only come from
    -- the parser, and they represent code which comes from reading a paren form;
    -- they are specifically not cons cells.
    local function list(...)
        return setmetatable({...}, LIST_MT)
    end

    -- Create a new symbol. Symbols are a compile-time construct in Fennel and are
    -- not exposed outside the compiler. Symbols have source data describing what
    -- file, line, etc that they came from.
    local function sym(str, scope, source)
        local s = {str, scope = scope}
        for k, v in pairs(source or {}) do
            if type(k) == 'string' then s[k] = v end
        end
        return setmetatable(s, SYMBOL_MT)
    end

    nilSym = sym("nil")

    -- Create a new sequence. Sequences are tables that come from the parser when
    -- it encounters a form with square brackets. They are treated as regular tables
    -- except when certain macros need to look for binding forms, etc specifically.
    local function sequence(...)
        -- can't use SEQUENCE_MT directly as the sequence metatable like we do with
        -- the other types without giving up the ability to set source metadata
        -- on a sequence, (which we need for error reporting) so embed a marker
        -- value in the metatable instead.
        return setmetatable({...}, {sequence=SEQUENCE_MARKER})
    end

    -- Create a new expr
    -- etype should be one of
    --   "literal": literals like numbers, strings, nil, true, false
    --   "expression": Complex strings of Lua code, may have side effects, etc
    --                 but is an expression
    --   "statement": Same as expression, but is also a valid statement
    --                (function calls).
    --   "vargs": varargs symbol
    --   "sym": symbol reference
    local function expr(strcode, etype)
        return setmetatable({ strcode, type = etype }, EXPR_MT)
    end

    local function varg()
        return VARARG
    end

    local function isExpr(x)
        return type(x) == 'table' and getmetatable(x) == EXPR_MT and x
    end

    local function isVarg(x)
        return x == VARARG and x
    end

    -- Checks if an object is a List. Returns the object if is a List.
    local function isList(x)
        return type(x) == 'table' and getmetatable(x) == LIST_MT and x
    end

    -- Checks if an object is a symbol. Returns the object if it is a symbol.
    local function isSym(x)
        return type(x) == 'table' and getmetatable(x) == SYMBOL_MT and x
    end

    -- Checks if an object any kind of table, EXCEPT list or symbol
    local function isTable(x)
        return type(x) == 'table' and
            x ~= VARARG and
            getmetatable(x) ~= LIST_MT and getmetatable(x) ~= SYMBOL_MT and x
    end

    -- Checks if an object is a sequence (created with a [] literal)
    local function isSequence(x)
        local mt = type(x) == "table" and getmetatable(x)
        return mt and mt.sequence == SEQUENCE_MARKER and x
    end

    -- A multi symbol is a symbol that is actually composed of
    -- two or more symbols using the dot syntax. The main differences
    -- from normal symbols is that they cannot be declared local, and
    -- they may have side effects on invocation (metatables)
    local function isMultiSym(str)
        if isSym(str) then
            return isMultiSym(tostring(str))
        end
        if type(str) ~= 'string' then return end
        local parts = {}
        for part in str:gmatch('[^%.%:]+[%.%:]?') do
            local lastChar = part:sub(-1)
            if lastChar == ":" then
                parts.multiSymMethodCall = true
            end
            if lastChar == ":" or lastChar == "." then
                parts[#parts + 1] = part:sub(1, -2)
            else
                parts[#parts + 1] = part
            end
        end
        return #parts > 0 and
            (str:match('%.') or str:match(':')) and
            (not str:match('%.%.')) and
            str:byte() ~= string.byte '.' and
            str:byte(-1) ~= string.byte '.' and
            parts
    end

    local function isQuoted(symbol) return symbol.quoted end

    local luaKeywords = {
        'and', 'break', 'do', 'else', 'elseif', 'end', 'false', 'for',
        'function', 'if', 'in', 'local', 'nil', 'not', 'or', 'repeat', 'return',
        'then', 'true', 'until', 'while'
    }

    for i, v in ipairs(luaKeywords) do luaKeywords[v] = i end

    local function isValidLuaIdentifier(str)
        return (str:match('^[%a_][%w_]*$') and not luaKeywords[str])
    end

    -- Certain options should always get propagated onwards when a function that
    -- has options calls down into compile.
    local propagatedOptions = {"allowedGlobals", "indent", "correlate",
                               "useMetadata", "env"}
    local function propagateOptions(options, subopts)
        for _,name in ipairs(propagatedOptions) do subopts[name] = options[name] end
        return subopts
    end

    local root = {
        -- Top level compilation bindings.
        chunk=nil, scope=nil, options=nil,

        -- The root.reset function needs to be called at every exit point of the
        -- compiler including when there's a parse error or compiler
        -- error. This would be better done using dynamic scope, but we don't
        -- have dynamic scope, so we fake it by ensuring we call this at every
        -- exit point, including errors.
        reset=function() end,

        setReset=function(root)
            local chunk, scope, options = root.chunk, root.scope, root.options
            local oldResetRoot = root.reset -- this needs to nest!
            root.reset = function()
                root.chunk, root.scope, root.options = chunk, scope, options
                root.reset = oldResetRoot
            end
        end,
    }

    return {
        -- basic general table functions:
        stablepairs=stablepairs, allpairs=allpairs, map=map, kvmap=kvmap,
        copy=copy,

        -- AST functions:
        list=list, sym=sym, sequence=sequence, expr=expr, varg=varg,
        isVarg=isVarg, isList=isList, isSym=isSym, isTable=isTable,
        isSequence=isSequence, isMultiSym=isMultiSym, isQuoted=isQuoted,
        isExpr=isExpr, deref=deref,

        -- other functions:
        isValidLuaIdentifier=isValidLuaIdentifier, luaKeywords=luaKeywords,
        propagateOptions=propagateOptions, debugOn=debugOn,
        root=root, path=table.concat(pathTable, ";"),}
end)()

--
-- Parser
--

local parser = (function()
    -- Convert a stream of chunks to a stream of bytes.
    -- Also returns a second function to clear the buffer in the byte stream
    local function granulate(getchunk)
        local c = ''
        local index = 1
        local done = false
        return function (parserState)
            if done then return nil end
            if index <= #c then
                local b = c:byte(index)
                index = index + 1
                return b
            else
                c = getchunk(parserState)
                if not c or c == '' then
                    done = true
                    return nil
                end
                index = 2
                return c:byte(1)
            end
        end, function ()
            c = ''
        end
    end

    -- Convert a string into a stream of bytes
    local function stringStream(str)
        str=str:gsub("^#![^\n]*\n", "") -- remove shebang
        local index = 1
        return function()
            local r = str:byte(index)
            index = index + 1
            return r
        end
    end

    -- Table of delimiter bytes - (, ), [, ], {, }
    -- Opener keys have closer as the value, and closers keys
    -- have true as their value.
    local delims = {
        [40] = 41,        -- (
        [41] = true,      -- )
        [91] = 93,        -- [
        [93] = true,      -- ]
        [123] = 125,      -- {
        [125] = true      -- }
    }

    local function iswhitespace(b)
        return b == 32 or (b >= 9 and b <= 13)
    end

    local function issymbolchar(b)
        return b > 32 and
            not delims[b] and
            b ~= 127 and -- "<BS>"
            b ~= 34 and -- "\""
            b ~= 39 and -- "'"
            b ~= 126 and -- "~"
            b ~= 59 and -- ";"
            b ~= 44 and -- ","
            b ~= 64 and -- "@"
            b ~= 96 -- "`"
    end

    local prefixes = { -- prefix chars substituted while reading
        [96] = 'quote', -- `
        [44] = 'unquote', -- ,
        [39] = 'quote', -- '
        [35] = 'hashfn' -- #
    }

    -- Parse one value given a function that
    -- returns sequential bytes. Will throw an error as soon
    -- as possible without getting more bytes on bad input. Returns
    -- if a value was read, and then the value read. Will return nil
    -- when input stream is finished.
    local function parser(getbyte, filename, options)

        -- Stack of unfinished values
        local stack = {}

        -- Provide one character buffer and keep
        -- track of current line and byte index
        local line = 1
        local byteindex = 0
        local lastb
        local function ungetb(ub)
            if ub == 10 then line = line - 1 end
            byteindex = byteindex - 1
            lastb = ub
        end
        local function getb()
            local r
            if lastb then
                r, lastb = lastb, nil
            else
                r = getbyte({ stackSize = #stack })
            end
            byteindex = byteindex + 1
            if r == 10 then line = line + 1 end
            return r
        end

        -- If you add new calls to this function, please update fenneldfriend.fnl
        -- as well to add suggestions for how to fix the new error.
        local function parseError(msg)
            local source = utils.root.options and utils.root.options.source
            utils.root.reset()
            local override = options and options["parse-error"]
            if override then override(msg, filename or "unknown", line or "?",
                                      byteindex, source) end
            return error(("Parse error in %s:%s: %s"):
                    format(filename or "unknown", line or "?", msg), 0)
        end

        -- Parse stream
        return function()

            -- Dispatch when we complete a value
            local done, retval
            local whitespaceSinceDispatch = true
            local function dispatch(v)
                if #stack == 0 then
                    retval = v
                    done = true
                elseif stack[#stack].prefix then
                    local stacktop = stack[#stack]
                    stack[#stack] = nil
                    return dispatch(utils.list(utils.sym(stacktop.prefix), v))
                else
                    table.insert(stack[#stack], v)
                end
                whitespaceSinceDispatch = false
            end

            -- Throw nice error when we expect more characters
            -- but reach end of stream.
            local function badend()
                local accum = utils.map(stack, "closer")
                parseError(('expected closing delimiter%s %s'):format(
                    #stack == 1 and "" or "s",
                    string.char(unpack(accum))))
            end

            -- The main parse loop
            repeat
                local b

                -- Skip whitespace
                repeat
                    b = getb()
                    if b and iswhitespace(b) then
                        whitespaceSinceDispatch = true
                    end
                until not b or not iswhitespace(b)
                if not b then
                    if #stack > 0 then badend() end
                    return nil
                end

                if b == 59 then -- ; Comment
                    repeat
                        b = getb()
                    until not b or b == 10 -- newline
                elseif type(delims[b]) == 'number' then -- Opening delimiter
                    if not whitespaceSinceDispatch then
                        parseError('expected whitespace before opening delimiter '
                                       .. string.char(b))
                    end
                    table.insert(stack, setmetatable({
                        closer = delims[b],
                        line = line,
                        filename = filename,
                        bytestart = byteindex
                    }, getmetatable(utils.list())))
                elseif delims[b] then -- Closing delimiter
                    if #stack == 0 then parseError('unexpected closing delimiter '
                                                       .. string.char(b)) end
                    local last = stack[#stack]
                    local val
                    if last.closer ~= b then
                        parseError('mismatched closing delimiter ' .. string.char(b) ..
                                   ', expected ' .. string.char(last.closer))
                    end
                    last.byteend = byteindex -- Set closing byte index
                    if b == 41 then -- ; )
                        val = last
                    elseif b == 93 then -- ; ]
                        val = utils.sequence(unpack(last))
                        -- for table literals we can store file/line/offset source
                        -- data in fields on the table itself, because the AST node
                        -- *is* the table, and the fields would show up in the
                        -- compiled output. keep them on the metatable instead.
                        for k,v in pairs(last) do getmetatable(val)[k]=v end
                    else -- ; }
                        if #last % 2 ~= 0 then
                            byteindex = byteindex - 1
                            parseError('expected even number of values in table literal')
                        end
                        val = {}
                        setmetatable(val, last) -- see note above about source data
                        for i = 1, #last, 2 do
                            if(tostring(last[i]) == ":" and utils.isSym(last[i + 1])
                               and utils.isSym(last[i])) then
                                last[i] = tostring(last[i + 1])
                            end
                            val[last[i]] = last[i + 1]
                        end
                    end
                    stack[#stack] = nil
                    dispatch(val)
                elseif b == 34 then -- Quoted string
                    local state = "base"
                    local chars = {34}
                    stack[#stack + 1] = {closer = 34}
                    repeat
                        b = getb()
                        chars[#chars + 1] = b
                        if state == "base" then
                            if b == 92 then
                                state = "backslash"
                            elseif b == 34 then
                                state = "done"
                            end
                        else
                            -- state == "backslash"
                            state = "base"
                        end
                    until not b or (state == "done")
                    if not b then badend() end
                    stack[#stack] = nil
                    local raw = string.char(unpack(chars))
                    local formatted = raw:gsub("[\1-\31]", function (c)
                                                   return '\\' .. c:byte() end)
                    local loadFn = (loadstring or load)(('return %s'):format(formatted))
                    dispatch(loadFn())
                elseif prefixes[b] then
                    -- expand prefix byte into wrapping form eg. '`a' into '(quote a)'
                    table.insert(stack, {
                        prefix = prefixes[b]
                    })
                    local nextb = getb()
                    if iswhitespace(nextb) then
                        if b == 35 then
                            stack[#stack] = nil
                            dispatch(utils.sym('#'))
                        else
                            parseError('invalid whitespace after quoting prefix')
                        end
                    end
                    ungetb(nextb)
                elseif issymbolchar(b) or b == string.byte("~") then -- Try sym
                    local chars = {}
                    local bytestart = byteindex
                    repeat
                        chars[#chars + 1] = b
                        b = getb()
                    until not b or not issymbolchar(b)
                    if b then ungetb(b) end
                    local rawstr = string.char(unpack(chars))
                    if rawstr == 'true' then dispatch(true)
                    elseif rawstr == 'false' then dispatch(false)
                    elseif rawstr == '...' then dispatch(utils.varg())
                    elseif rawstr:match('^:.+$') then -- colon style strings
                        dispatch(rawstr:sub(2))
                    elseif rawstr:match("^~") and rawstr ~= "~=" then
                        -- for backwards-compatibility, special-case allowance
                        -- of ~= but all other uses of ~ are disallowed
                        parseError("illegal character: ~")
                    else
                        local forceNumber = rawstr:match('^%d')
                        local numberWithStrippedUnderscores = rawstr:gsub("_", "")
                        local x
                        if forceNumber then
                            x = tonumber(numberWithStrippedUnderscores) or
                                parseError('could not read number "' .. rawstr .. '"')
                        else
                            x = tonumber(numberWithStrippedUnderscores)
                            if not x then
                                if(rawstr:match("%.[0-9]")) then
                                    byteindex = (byteindex - #rawstr +
                                                     rawstr:find("%.[0-9]") + 1)
                                    parseError("can't start multisym segment " ..
                                                   "with a digit: ".. rawstr)
                                elseif(rawstr:match("[%.:][%.:]") and
                                       rawstr ~= "..") then
                                    byteindex = (byteindex - #rawstr +
                                                     rawstr:find("[%.:][%.:]") + 1)
                                    parseError("malformed multisym: " .. rawstr)
                                elseif(rawstr:match(":.+[%.:]")) then
                                    byteindex = (byteindex - #rawstr +
                                                     rawstr:find(":.+[%.:]"))
                                    parseError("method must be last component "
                                                   .. "of multisym: " .. rawstr)
                                else
                                    x = utils.sym(rawstr, nil, {line = line,
                                                          filename = filename,
                                                          bytestart = bytestart,
                                                          byteend = byteindex,})
                                end
                            end
                        end
                        dispatch(x)
                    end
                else
                    parseError("illegal character: " .. string.char(b))
                end
            until done
            return true, retval
        end, function ()
            stack = {}
        end
    end
    return { granulate=granulate, stringStream=stringStream, parser=parser }
end)()

--
-- Compilation
--

local compiler = (function()
    local scopes = {}

    -- Create a new Scope, optionally under a parent scope. Scopes are compile time
    -- constructs that are responsible for keeping track of local variables, name
    -- mangling, and macros.  They are accessible to user code via the
    -- 'eval-compiler' special form (may change). They use metatables to implement
    -- nesting.
    local function makeScope(parent)
        if not parent then parent = scopes.global end
        return {
            unmanglings = setmetatable({}, {
                __index = parent and parent.unmanglings
            }),
            manglings = setmetatable({}, {
                __index = parent and parent.manglings
            }),
            specials = setmetatable({}, {
                __index = parent and parent.specials
            }),
            macros = setmetatable({}, {
                __index = parent and parent.macros
            }),
            symmeta = setmetatable({}, {
                __index = parent and parent.symmeta
            }),
            includes = setmetatable({}, {
                __index = parent and parent.includes
            }),
            refedglobals = setmetatable({}, {
                __index = parent and parent.refedglobals
            }),
            autogensyms = {},
            parent = parent,
            vararg = parent and parent.vararg,
            depth = parent and ((parent.depth or 0) + 1) or 0,
            hashfn = parent and parent.hashfn
        }
    end

    -- Assert a condition and raise a compile error with line numbers. The ast arg
    -- should be unmodified so that its first element is the form being called.
    -- If you add new calls to this function, please update fenneldfriend.fnl
    -- as well to add suggestions for how to fix the new error.
    local function assertCompile(condition, msg, ast)
        local override = utils.root.options and utils.root.options["assert-compile"]
        if override then
            local source = utils.root.options and utils.root.options.source
            -- don't make custom handlers deal with resetting root; it's error-prone
            if not condition then utils.root.reset() end
            override(condition, msg, ast, source)
            -- should we fall thru to the default check, or should we allow the
            -- override to swallow the error?
        end
        if not condition then
            utils.root.reset()
            local m = getmetatable(ast)
            local filename = m and m.filename or ast.filename or "unknown"
            local line = m and m.line or ast.line or "?"
            -- if we use regular `assert' we can't provide the `level' argument of 0
            error(string.format("Compile error in '%s' %s:%s: %s",
                                tostring(utils.isSym(ast[1]) and ast[1][1] or
                                             ast[1] or '()'),
                                filename, line, msg), 0)
        end
        return condition
    end

    scopes.global = makeScope()
    scopes.global.vararg = true
    scopes.compiler = makeScope(scopes.global)
    scopes.macro = scopes.global -- used by gensym, in-scope?, etc

    -- Allow printing a string to Lua, also keep as 1 line.
    local serializeSubst = {
        ['\a'] = '\\a',
        ['\b'] = '\\b',
        ['\f'] = '\\f',
        ['\n'] = 'n',
        ['\t'] = '\\t',
        ['\v'] = '\\v'
    }
    local function serializeString(str)
        local s = ("%q"):format(str)
        s = s:gsub('.', serializeSubst):gsub("[\128-\255]", function(c)
            return "\\" .. c:byte()
        end)
        return s
    end

    -- Mangler for global symbols. Does not protect against collisions,
    -- but makes them unlikely. This is the mangling that is exposed to
    -- to the world.
    local function globalMangling(str)
        if utils.isValidLuaIdentifier(str) then
            return str
        end
        -- Use underscore as escape character
        return '__fnl_global__' .. str:gsub('[^%w]', function (c)
            return ('_%02x'):format(c:byte())
        end)
    end

    -- Reverse a global mangling. Takes a Lua identifier and
    -- returns the fennel symbol string that created it.
    local function globalUnmangling(identifier)
        local rest = identifier:match('^__fnl_global__(.*)$')
        if rest then
            local r = rest:gsub('_[%da-f][%da-f]', function (code)
                return string.char(tonumber(code:sub(2), 16))
            end)
            return r -- don't return multiple values
        else
            return identifier
        end
    end

    -- If there's a provided list of allowed globals, don't let references thru that
    -- aren't on the list. This list is set at the compiler entry points of compile
    -- and compileStream.
    local allowedGlobals

    local function globalAllowed(name)
        if not allowedGlobals then return true end
        for _, g in ipairs(allowedGlobals) do
            if g == name then return true end
        end
    end

    -- Creates a symbol from a string by mangling it.
    -- ensures that the generated symbol is unique
    -- if the input string is unique in the scope.
    local function localMangling(str, scope, ast, tempManglings)
        local append = 0
        local mangling = str
        assertCompile(not utils.isMultiSym(str), 'unexpected multi symbol ' .. str, ast)

        -- Mapping mangling to a valid Lua identifier
        if utils.luaKeywords[mangling] or mangling:match('^%d') then
            mangling = '_' .. mangling
        end
        mangling = mangling:gsub('-', '_')
        mangling = mangling:gsub('[^%w_]', function (c)
            return ('_%02x'):format(c:byte())
        end)

        -- Prevent name collisions with existing symbols
        local raw = mangling
        while scope.unmanglings[mangling] do
            mangling = raw .. append
            append = append + 1
        end

        scope.unmanglings[mangling] = str
        local manglings = tempManglings or scope.manglings
        manglings[str] = mangling
        return mangling
    end

    -- Calling this function will mean that further
    -- compilation in scope will use these new manglings
    -- instead of the current manglings.
    local function applyManglings(scope, newManglings, ast)
        for raw, mangled in pairs(newManglings) do
            assertCompile(not scope.refedglobals[mangled],
            "use of global " .. raw .. " is aliased by a local", ast)
            scope.manglings[raw] = mangled
        end
    end

    -- Combine parts of a symbol
    local function combineParts(parts, scope)
        local ret = scope.manglings[parts[1]] or globalMangling(parts[1])
        for i = 2, #parts do
            if utils.isValidLuaIdentifier(parts[i]) then
                if parts.multiSymMethodCall and i == #parts then
                    ret = ret .. ':' .. parts[i]
                else
                    ret = ret .. '.' .. parts[i]
                end
            else
                ret = ret .. '[' .. serializeString(parts[i]) .. ']'
            end
        end
        return ret
    end

    -- Generates a unique symbol in the scope.
    local function gensym(scope, base)
        local mangling
        local append = 0
        repeat
            mangling = (base or '') .. '_' .. append .. '_'
            append = append + 1
        until not scope.unmanglings[mangling]
        scope.unmanglings[mangling] = true
        return mangling
    end

    -- Generates a unique symbol in the scope based on the base name. Calling
    -- repeatedly with the same base and same scope will return existing symbol
    -- rather than generating new one.
    local function autogensym(base, scope)
        local parts = utils.isMultiSym(base)
        if(parts) then
            parts[1] = autogensym(parts[1], scope)
            return table.concat(parts, parts.multiSymMethodCall and ":" or ".")
        end

        if scope.autogensyms[base] then return scope.autogensyms[base] end
        local mangling = gensym(scope, base:sub(1, -2))
        scope.autogensyms[base] = mangling
        return mangling
    end

    -- Check if a binding is valid
    local function checkBindingValid(symbol, scope, ast)
        -- Check if symbol will be over shadowed by special
        local name = symbol[1]
        assertCompile(not scope.specials[name] and not scope.macros[name],
                      ("local %s was overshadowed by a special form or macro")
                          :format(name), ast)
        assertCompile(not utils.isQuoted(symbol),
                      ("macro tried to bind %s without gensym"):format(name), symbol)

    end

    -- Declare a local symbol
    local function declareLocal(symbol, meta, scope, ast, tempManglings)
        checkBindingValid(symbol, scope, ast)
        local name = symbol[1]
        assertCompile(not utils.isMultiSym(name),
                      "unexpected multi symbol " .. name, ast)
        local mangling = localMangling(name, scope, ast, tempManglings)
        scope.symmeta[name] = meta
        return mangling
    end

    -- Convert symbol to Lua code. Will only work for local symbols
    -- if they have already been declared via declareLocal
    local function symbolToExpression(symbol, scope, isReference)
        local name = symbol[1]
        local multiSymParts = utils.isMultiSym(name)
        if scope.hashfn then
           if name == '$' then name = '$1' end
           if multiSymParts then
              if multiSymParts[1] == "$" then
                 multiSymParts[1] = "$1"
                 name = table.concat(multiSymParts, ".")
              end
           end
        end
        local parts = multiSymParts or {name}
        local etype = (#parts > 1) and "expression" or "sym"
        local isLocal = scope.manglings[parts[1]]
        if isLocal and scope.symmeta[parts[1]] then scope.symmeta[parts[1]].used = true end
        -- if it's a reference and not a symbol which introduces a new binding
        -- then we need to check for allowed globals
        assertCompile(not isReference or isLocal or globalAllowed(parts[1]),
                      'unknown global in strict mode: ' .. parts[1], symbol)
        if not isLocal then
            utils.root.scope.refedglobals[parts[1]] = true
        end
        return utils.expr(combineParts(parts, scope), etype)
    end


    -- Emit Lua code
    local function emit(chunk, out, ast)
        if type(out) == 'table' then
            table.insert(chunk, out)
        else
            table.insert(chunk, {leaf = out, ast = ast})
        end
    end

    -- Do some peephole optimization.
    local function peephole(chunk)
        if chunk.leaf then return chunk end
        -- Optimize do ... end in some cases.
        if #chunk >= 3 and
            chunk[#chunk - 2].leaf == 'do' and
            not chunk[#chunk - 1].leaf and
            chunk[#chunk].leaf == 'end' then
            local kid = peephole(chunk[#chunk - 1])
            local newChunk = {ast = chunk.ast}
            for i = 1, #chunk - 3 do table.insert(newChunk, peephole(chunk[i])) end
            for i = 1, #kid do table.insert(newChunk, kid[i]) end
            return newChunk
        end
        -- Recurse
        return utils.map(chunk, peephole)
    end

    -- correlate line numbers in input with line numbers in output
    local function flattenChunkCorrelated(mainChunk)
        local function flatten(chunk, out, lastLine, file)
            if chunk.leaf then
                out[lastLine] = (out[lastLine] or "") .. " " .. chunk.leaf
            else
                for _, subchunk in ipairs(chunk) do
                    -- Ignore empty chunks
                    if subchunk.leaf or #subchunk > 0 then
                        -- don't increase line unless it's from the same file
                        if subchunk.ast and file == subchunk.ast.file then
                            lastLine = math.max(lastLine, subchunk.ast.line or 0)
                        end
                        lastLine = flatten(subchunk, out, lastLine, file)
                    end
                end
            end
            return lastLine
        end
        local out = {}
        local last = flatten(mainChunk, out, 1, mainChunk.file)
        for i = 1, last do
            if out[i] == nil then out[i] = "" end
        end
        return table.concat(out, "\n")
    end

    -- Flatten a tree of indented Lua source code lines.
    -- Tab is what is used to indent a block.
    local function flattenChunk(sm, chunk, tab, depth)
        if type(tab) == 'boolean' then tab = tab and '  ' or '' end
        if chunk.leaf then
            local code = chunk.leaf
            local info = chunk.ast
            -- Just do line info for now to save memory
            if sm then sm[#sm + 1] = info and info.line or -1 end
            return code
        else
            local parts = utils.map(chunk, function(c)
                if c.leaf or #c > 0 then -- Ignore empty chunks
                    local sub = flattenChunk(sm, c, tab, depth + 1)
                    if depth > 0 then sub = tab .. sub:gsub('\n', '\n' .. tab) end
                    return sub
                end
            end)
            return table.concat(parts, '\n')
        end
    end

    -- Some global state for all fennel sourcemaps. For the time being,
    -- this seems the easiest way to store the source maps.
    -- Sourcemaps are stored with source being mapped as the key, prepended
    -- with '@' if it is a filename (like debug.getinfo returns for source).
    -- The value is an array of mappings for each line.
    local fennelSourcemap = {}
    -- TODO: loading, unloading, and saving sourcemaps?

    local function makeShortSrc(source)
        source = source:gsub('\n', ' ')
        if #source <= 49 then
            return '[fennel "' .. source .. '"]'
        else
            return '[fennel "' .. source:sub(1, 46) .. '..."]'
        end
    end

    -- Return Lua source and source map table
    local function flatten(chunk, options)
        chunk = peephole(chunk)
        if(options.correlate) then
            return flattenChunkCorrelated(chunk), {}
        else
            local sm = {}
            local ret = flattenChunk(sm, chunk, options.indent, 0)
            if sm then
                local key, short_src
                if options.filename then
                    short_src = options.filename
                    key = '@' .. short_src
                else
                    key = ret
                    short_src = makeShortSrc(options.source or ret)
                end
                sm.short_src = short_src
                sm.key = key
                fennelSourcemap[key] = sm
            end
            return ret, sm
        end
    end

    -- module-wide state for metadata
    -- create metadata table with weakly-referenced keys
    local function makeMetadata()
        return setmetatable({}, {
            __mode = 'k',
            __index = {
                get = function(self, tgt, key)
                    if self[tgt] then return self[tgt][key] end
                end,
                set = function(self, tgt, key, value)
                    self[tgt] = self[tgt] or {}
                    self[tgt][key] = value
                    return tgt
                end,
                setall = function(self, tgt, ...)
                    local kvLen, kvs = select('#', ...), {...}
                    if kvLen % 2 ~= 0 then
                        error('metadata:setall() expected even number of k/v pairs')
                    end
                    self[tgt] = self[tgt] or {}
                    for i = 1, kvLen, 2 do self[tgt][kvs[i]] = kvs[i + 1] end
                    return tgt
                end,
            }})
    end

    -- Convert expressions to Lua string
    local function exprs1(exprs)
        return table.concat(utils.map(exprs, 1), ', ')
    end

    -- Compile side effects for a chunk
    local function keepSideEffects(exprs, chunk, start, ast)
        start = start or 1
        for j = start, #exprs do
            local se = exprs[j]
            -- Avoid the rogue 'nil' expression (nil is usually a literal,
            -- but becomes an expression if a special form
            -- returns 'nil'.)
            if se.type == 'expression' and se[1] ~= 'nil' then
                emit(chunk, ('do local _ = %s end'):format(tostring(se)), ast)
            elseif se.type == 'statement' then
                local code = tostring(se)
                emit(chunk, code:byte() == 40 and ("do end " .. code) or code , ast)
            end
        end
    end

    -- Does some common handling of returns and register
    -- targets for special forms. Also ensures a list expression
    -- has an acceptable number of expressions if opts contains the
    -- "nval" option.
    local function handleCompileOpts(exprs, parent, opts, ast)
        if opts.nval then
            local n = opts.nval
            if n ~= #exprs then
                local len = #exprs
                if len > n then
                    -- Drop extra
                    keepSideEffects(exprs, parent, n + 1, ast)
                    for i = n + 1, len do
                        exprs[i] = nil
                    end
                else
                    -- Pad with nils
                    for i = #exprs + 1, n do
                        exprs[i] = utils.expr('nil', 'literal')
                    end
                end
            end
        end
        if opts.tail then
            emit(parent, ('return %s'):format(exprs1(exprs)), ast)
        end
        if opts.target then
            local result = exprs1(exprs)
            if result == '' then result = 'nil' end
            emit(parent, ('%s = %s'):format(opts.target, result), ast)
        end
        if opts.tail or opts.target then
            -- Prevent statements and expression from being used twice if they
            -- have side-effects. Since if the target or tail options are set,
            -- the expressions are already emitted, we should not return them. This
            -- is fine, as when these options are set, the caller doesn't need the result
            -- anyways.
            exprs = {}
        end
        return exprs
    end

    local function macroexpand(ast, scope, once)
        if not utils.isList(ast) then return ast end -- bail early if not a list form
        local multiSymParts = utils.isMultiSym(ast[1])
        local macro = utils.isSym(ast[1]) and scope.macros[utils.deref(ast[1])]
        if not macro and multiSymParts then
            local inMacroModule
            macro = scope.macros
            for i = 1, #multiSymParts do
                macro = utils.isTable(macro) and macro[multiSymParts[i]]
                if macro then inMacroModule = true end
            end
            assertCompile(not inMacroModule or type(macro) == 'function',
                'macro not found in imported macro module', ast)
        end
        if not macro then return ast end
        local oldScope = scopes.macro
        scopes.macro = scope
        local ok, transformed = pcall(macro, unpack(ast, 2))
        scopes.macro = oldScope
        assertCompile(ok, transformed, ast)
        if once or not transformed then return transformed end -- macroexpand-1
        return macroexpand(transformed, scope)
    end

    -- Compile an AST expression in the scope into parent, a tree
    -- of lines that is eventually compiled into Lua code. Also
    -- returns some information about the evaluation of the compiled expression,
    -- which can be used by the calling function. Macros
    -- are resolved here, as well as special forms in that order.
    -- the 'ast' param is the root AST to compile
    -- the 'scope' param is the scope in which we are compiling
    -- the 'parent' param is the table of lines that we are compiling into.
    -- add lines to parent by appending strings. Add indented blocks by appending
    -- tables of more lines.
    -- the 'opts' param contains info about where the form is being compiled.
    -- Options include:
    --   'target' - mangled name of symbol(s) being compiled to.
    --      Could be one variable, 'a', or a list, like 'a, b, _0_'.
    --   'tail' - boolean indicating tail position if set. If set, form will generate a return
    --   instruction.
    --   'nval' - The number of values to compile to if it is known to be a fixed value.

    -- In Lua, an expression can evaluate to 0 or more values via multiple
    -- returns. In many cases, Lua will drop extra values and convert a 0 value
    -- expression to nil. In other cases, Lua will use all of the values in an
    -- expression, such as in the last argument of a function call. Nval is an
    -- option passed to compile1 to say that the resulting expression should have
    -- at least n values. It lets us generate better code, because if we know we
    -- are only going to use 1 or 2 values from an expression, we can create 1 or 2
    -- locals to store intermediate results rather than turn the expression into a
    -- closure that is called immediately, which we have to do if we don't know.

    local function compile1(ast, scope, parent, opts)
        opts = opts or {}
        local exprs = {}
        -- expand any top-level macros before parsing and emitting Lua
        ast = macroexpand(ast, scope)
        -- Compile the form
        if utils.isList(ast) then -- Function call or special form
            assertCompile(#ast > 0, "expected a function, macro, or special to call", ast)
            -- Test for special form
            local len, first = #ast, ast[1]
            local multiSymParts = utils.isMultiSym(first)
            local special = utils.isSym(first) and scope.specials[utils.deref(first)]
            if special then -- Special form
                exprs = special(ast, scope, parent, opts) or utils.expr('nil', 'literal')
                -- Be very accepting of strings or expression
                -- as well as lists or expressions
                if type(exprs) == 'string' then exprs = utils.expr(exprs, 'expression') end
                if utils.isExpr(exprs) then exprs = {exprs} end
                -- Unless the special form explicitly handles the target, tail, and
                -- nval properties, (indicated via the 'returned' flag), handle
                -- these options.
                if not exprs.returned then
                    exprs = handleCompileOpts(exprs, parent, opts, ast)
                elseif opts.tail or opts.target then
                    exprs = {}
                end
                exprs.returned = true
                return exprs
            elseif multiSymParts and multiSymParts.multiSymMethodCall then
                local tableWithMethod = table.concat({
                        unpack(multiSymParts, 1, #multiSymParts - 1)
                                                     }, '.')
                local methodToCall = multiSymParts[#multiSymParts]
                local newAST = utils.list(utils.sym(':', scope), utils.sym(tableWithMethod, scope),
                                          methodToCall)
                for i = 2, len do
                    newAST[#newAST + 1] = ast[i]
                end
                local compiled = compile1(newAST, scope, parent, opts)
                exprs = compiled
            else -- Function call
                local fargs = {}
                local fcallee = compile1(ast[1], scope, parent, {
                    nval = 1
                })[1]
                assertCompile(fcallee.type ~= 'literal',
                              'cannot call literal value', ast)
                fcallee = tostring(fcallee)
                for i = 2, len do
                    local subexprs = compile1(ast[i], scope, parent, {
                        nval = i ~= len and 1 or nil
                    })
                    fargs[#fargs + 1] = subexprs[1] or utils.expr('nil', 'literal')
                    if i == len then
                        -- Add sub expressions to function args
                        for j = 2, #subexprs do
                            fargs[#fargs + 1] = subexprs[j]
                        end
                    else
                        -- Emit sub expression only for side effects
                        keepSideEffects(subexprs, parent, 2, ast[i])
                    end
                end
                local call = ('%s(%s)'):format(tostring(fcallee), exprs1(fargs))
                exprs = handleCompileOpts({utils.expr(call, 'statement')}, parent, opts, ast)
            end
        elseif utils.isVarg(ast) then
            assertCompile(scope.vararg, "unexpected vararg", ast)
            exprs = handleCompileOpts({utils.expr('...', 'varg')}, parent, opts, ast)
        elseif utils.isSym(ast) then
            local e
            local multiSymParts = utils.isMultiSym(ast)
            assertCompile(not (multiSymParts and multiSymParts.multiSymMethodCall),
                          "multisym method calls may only be in call position", ast)
            -- Handle nil as special symbol - it resolves to the nil literal rather than
            -- being unmangled. Alternatively, we could remove it from the lua keywords table.
            if ast[1] == 'nil' then
                e = utils.expr('nil', 'literal')
            else
                e = symbolToExpression(ast, scope, true)
            end
            exprs = handleCompileOpts({e}, parent, opts, ast)
        elseif type(ast) == 'nil' or type(ast) == 'boolean' then
            exprs = handleCompileOpts({utils.expr(tostring(ast), 'literal')}, parent, opts)
        elseif type(ast) == 'number' then
            local n = ('%.17g'):format(ast)
            exprs = handleCompileOpts({utils.expr(n, 'literal')}, parent, opts)
        elseif type(ast) == 'string' then
            local s = serializeString(ast)
            exprs = handleCompileOpts({utils.expr(s, 'literal')}, parent, opts)
        elseif type(ast) == 'table' then
            local buffer = {}
            for i = 1, #ast do -- Write numeric keyed values.
                local nval = i ~= #ast and 1
                buffer[#buffer + 1] = exprs1(compile1(ast[i], scope,
                                                      parent, {nval = nval}))
            end
            local function writeOtherValues(k)
                if type(k) ~= 'number' or math.floor(k) ~= k or k < 1 or k > #ast then
                    if type(k) == 'string' and utils.isValidLuaIdentifier(k) then
                        return {k, k}
                    else
                        local kstr = '[' .. tostring(compile1(k, scope, parent,
                                                              {nval = 1})[1]) .. ']'
                        return { kstr, k }
                    end
                end
            end
            local keys = utils.kvmap(ast, writeOtherValues)
            table.sort(keys, function (a, b) return a[1] < b[1] end)
            utils.map(keys, function(k)
                    local v = tostring(compile1(ast[k[2]], scope, parent, {nval = 1})[1])
                    return ('%s = %s'):format(k[1], v) end,
                buffer)
            local tbl = '{' .. table.concat(buffer, ', ') ..'}'
            exprs = handleCompileOpts({utils.expr(tbl, 'expression')}, parent, opts, ast)
        else
            assertCompile(false, 'could not compile value of type ' .. type(ast), ast)
        end
        exprs.returned = true
        return exprs
    end

    -- Implements destructuring for forms like let, bindings, etc.
    -- Takes a number of options to control behavior.
    -- var: Whether or not to mark symbols as mutable
    -- declaration: begin each assignment with 'local' in output
    -- nomulti: disallow multisyms in the destructuring. Used for (local) and (global).
    -- noundef: Don't set undefined bindings. (set)
    -- forceglobal: Don't allow local bindings
    local function destructure(to, from, ast, scope, parent, opts)
        opts = opts or {}
        local isvar = opts.isvar
        local declaration = opts.declaration
        local nomulti = opts.nomulti
        local noundef = opts.noundef
        local forceglobal = opts.forceglobal
        local forceset = opts.forceset
        local setter = declaration and "local %s = %s" or "%s = %s"

        local newManglings = {}

        -- Get Lua source for symbol, and check for errors
        local function getname(symbol, up1)
            local raw = symbol[1]
            assertCompile(not (nomulti and utils.isMultiSym(raw)),
                'unexpected multi symbol ' .. raw, up1)
            if declaration then
                return declareLocal(symbol, {var = isvar}, scope,
                                    symbol, newManglings)
            else
                local parts = utils.isMultiSym(raw) or {raw}
                local meta = scope.symmeta[parts[1]]
                if #parts == 1 and not forceset then
                    assertCompile(not(forceglobal and meta),
                        ("global %s conflicts with local"):format(tostring(symbol)), symbol)
                    assertCompile(not (meta and not meta.var),
                        'expected var ' .. raw, symbol)
                    assertCompile(meta or not noundef,
                        'expected local ' .. parts[1], symbol)
                end
                if forceglobal then
                    assertCompile(not scope.symmeta[scope.unmanglings[raw]],
                                  "global " .. raw .. " conflicts with local", symbol)
                    scope.manglings[raw] = globalMangling(raw)
                    scope.unmanglings[globalMangling(raw)] = raw
                    if allowedGlobals then
                        table.insert(allowedGlobals, raw)
                    end
                end

                return symbolToExpression(symbol, scope)[1]
            end
        end

        -- Compile the outer most form. We can generate better Lua in this case.
        local function compileTopTarget(lvalues)
            -- Calculate initial rvalue
            local inits = utils.map(lvalues, function(x)
                                  return scope.manglings[x] and x or 'nil' end)
            local init = table.concat(inits, ', ')
            local lvalue = table.concat(lvalues, ', ')

            local plen = #parent
            local ret = compile1(from, scope, parent, {target = lvalue})
            if declaration then
                if #parent == plen + 1 and parent[#parent].leaf then
                    -- A single leaf emitted means an simple assignment a = x was emitted
                    parent[#parent].leaf = 'local ' .. parent[#parent].leaf
                else
                    table.insert(parent, plen + 1, { leaf = 'local ' .. lvalue ..
                                                         ' = ' .. init, ast = ast})
                end
            end
            return ret
        end

        -- Recursive auxiliary function
        local function destructure1(left, rightexprs, up1, top)
            if utils.isSym(left) and left[1] ~= "nil" then
                checkBindingValid(left, scope, left)
                local lname = getname(left, up1)
                if top then
                    compileTopTarget({lname})
                else
                    emit(parent, setter:format(lname, exprs1(rightexprs)), left)
                end
            elseif utils.isTable(left) then -- table destructuring
                if top then rightexprs = compile1(from, scope, parent) end
                local s = gensym(scope)
                local right = exprs1(rightexprs)
                if right == '' then right = 'nil' end
                emit(parent, ("local %s = %s"):format(s, right), left)
                for k, v in utils.stablepairs(left) do
                    if utils.isSym(left[k]) and left[k][1] == "&" then
                        assertCompile(type(k) == "number" and not left[k+2],
                            "expected rest argument before last parameter", left)
                        local subexpr = utils.expr(('{(table.unpack or unpack)(%s, %s)}')
                                :format(s, k), 'expression')
                        destructure1(left[k+1], {subexpr}, left)
                        return
                    else
                        if utils.isSym(k) and tostring(k) == ":" and utils.isSym(v) then
                            k = tostring(v)
                        end
                        if type(k) ~= "number" then k = serializeString(k) end
                        local subexpr = utils.expr(('%s[%s]'):format(s, k), 'expression')
                        destructure1(v, {subexpr}, left)
                    end
                end
            elseif utils.isList(left) then -- values destructuring
                local leftNames, tables = {}, {}
                for i, name in ipairs(left) do
                    local symname
                    if utils.isSym(name) then -- binding directly to a name
                        symname = getname(name, up1)
                    else -- further destructuring of tables inside values
                        symname = gensym(scope)
                        tables[i] = {name, utils.expr(symname, 'sym')}
                    end
                    table.insert(leftNames, symname)
                end
                if top then
                    compileTopTarget(leftNames)
                else
                    local lvalue = table.concat(leftNames, ', ')
                    emit(parent, setter:format(lvalue, exprs1(rightexprs)), left)
                end
                for _, pair in utils.stablepairs(tables) do -- recurse if left-side tables found
                    destructure1(pair[1], {pair[2]}, left)
                end
            else
                assertCompile(false, ("unable to bind %s %s"):
                                  format(type(left), tostring(left)),
                              type(up1[2]) == "table" and up1[2] or up1)
            end
            if top then return {returned = true} end
        end

        local ret = destructure1(to, nil, ast, true)
        applyManglings(scope, newManglings, ast)
        return ret
    end

    local function requireInclude(ast, scope, parent, opts)
        opts.fallback = function(e)
            return utils.expr(('require(%s)'):format(tostring(e)), 'statement')
        end
        return scopes.global.specials['include'](ast, scope, parent, opts)
    end

    local function compileStream(strm, options)
        local opts = utils.copy(options)
        local oldGlobals = allowedGlobals
        utils.root:setReset()
        allowedGlobals = opts.allowedGlobals
        if opts.indent == nil then opts.indent = '  ' end
        local scope = opts.scope or makeScope(scopes.global)
        if opts.requireAsInclude then scope.specials.require = requireInclude end
        local vals = {}
        for ok, val in parser.parser(strm, opts.filename, opts) do
            if not ok then break end
            vals[#vals + 1] = val
        end
        local chunk = {}
        utils.root.chunk, utils.root.scope, utils.root.options = chunk, scope, opts
        for i = 1, #vals do
            local exprs = compile1(vals[i], scope, chunk, {
                tail = i == #vals,
                nval = i < #vals and 0 or nil
            })
            keepSideEffects(exprs, chunk, nil, vals[i])
        end
        allowedGlobals = oldGlobals
        utils.root.reset()
        return flatten(chunk, opts)
    end

    local function compileString(str, options)
        options = options or {}
        local oldSource = options.source
        options.source = str -- used by fennelfriend
        local ast = compileStream(parser.stringStream(str), options)
        options.source = oldSource
        return ast
    end

    local function compile(ast, options)
        local opts = utils.copy(options)
        local oldGlobals = allowedGlobals
        utils.root:setReset()
        allowedGlobals = opts.allowedGlobals
        if opts.indent == nil then opts.indent = '  ' end
        local chunk = {}
        local scope = opts.scope or makeScope(scopes.global)
        utils.root.chunk, utils.root.scope, utils.root.options = chunk, scope, opts
        if opts.requireAsInclude then scope.specials.require = requireInclude end
        local exprs = compile1(ast, scope, chunk, {tail = true})
        keepSideEffects(exprs, chunk, nil, ast)
        allowedGlobals = oldGlobals
        utils.root.reset()
        return flatten(chunk, opts)
    end

    -- A custom traceback function for Fennel that looks similar to
    -- the Lua's debug.traceback.
    -- Use with xpcall to produce fennel specific stacktraces.
    local function traceback(msg, start)
        local level = start or 2 -- Can be used to skip some frames
        local lines = {}
        if msg then
            if msg:find("^Compile error") or msg:find("^Parse error") then
                -- End users don't want to see compiler stack traces, but when
                -- you're hacking on the compiler, export FENNEL_DEBUG=trace
                if not utils.debugOn("trace") then return msg end
                table.insert(lines, msg)
            else
                local newmsg = msg:gsub('^[^:]*:%d+:%s+', 'runtime error: ')
                table.insert(lines, newmsg)
            end
        end
        table.insert(lines, 'stack traceback:')
        while true do
            local info = debug.getinfo(level, "Sln")
            if not info then break end
            local line
            if info.what == "C" then
                if info.name then
                    line = ('  [C]: in function \'%s\''):format(info.name)
                else
                    line = '  [C]: in ?'
                end
            else
                local remap = fennelSourcemap[info.source]
                if remap and remap[info.currentline] then
                    -- And some global info
                    info.short_src = remap.short_src
                    local mapping = remap[info.currentline]
                    -- Overwrite info with values from the mapping (mapping is now
                    -- just integer, but may eventually be a table)
                    info.currentline = mapping
                end
                if info.what == 'Lua' then
                    local n = info.name and ("'" .. info.name .. "'") or '?'
                    line = ('  %s:%d: in function %s'):format(info.short_src, info.currentline, n)
                elseif info.short_src == '(tail call)' then
                    line = '  (tail call)'
                else
                    line = ('  %s:%d: in main chunk'):format(info.short_src, info.currentline)
                end
            end
            table.insert(lines, line)
            level = level + 1
        end
        return table.concat(lines, '\n')
    end

    -- make a transformer for key / value table pairs, preserving all numeric keys
    local function entryTransform(fk,fv)
        return function(k, v)
            if type(k) == 'number' then
                return k,fv(v)
            else
                return fk(k),fv(v)
            end
        end
    end

    -- consume everything return nothing
    local function no() end

    local function mixedConcat(t, joiner)
        local ret = ""
        local s = ""
        local seen = {}
        for k,v in ipairs(t) do
            table.insert(seen, k)
            ret = ret .. s .. v
            s = joiner
        end
        for k,v in utils.stablepairs(t) do
            if not(seen[k]) then
                ret = ret .. s .. '[' .. k .. ']' .. '=' .. v
                s = joiner
            end
        end
        return ret
    end

    -- expand a quoted form into a data literal, evaluating unquote
    local function doQuote (form, scope, parent, runtime)
        local q = function (x) return doQuote(x, scope, parent, runtime) end
        -- vararg
        if utils.isVarg(form) then
            assertCompile(not runtime, "quoted ... may only be used at compile time", form)
            return "_VARARG"
        -- symbol
        elseif utils.isSym(form) then
            assertCompile(not runtime, "symbols may only be used at compile time", form)
            -- We should be able to use "%q" for this but Lua 5.1 throws an error
            -- when you try to format nil, because it's extremely bad.
            local filename = form.filename and ('%q'):format(form.filename) or "nil"
            if utils.deref(form):find("#$") or utils.deref(form):find("#[:.]") then -- autogensym
                return ("sym('%s', nil, {filename=%s, line=%s})"):
                    format(autogensym(utils.deref(form), scope), filename, form.line or "nil")
            else -- prevent non-gensymmed symbols from being bound as an identifier
                return ("sym('%s', nil, {quoted=true, filename=%s, line=%s})"):
                    format(utils.deref(form), filename, form.line or "nil")
            end
        -- unquote
        elseif(utils.isList(form) and utils.isSym(form[1]) and
               (utils.deref(form[1]) == 'unquote')) then
            local payload = form[2]
            local res = unpack(compile1(payload, scope, parent))
            return res[1]
        -- list
        elseif utils.isList(form) then
            assertCompile(not runtime, "lists may only be used at compile time", form)
            local mapped = utils.kvmap(form, entryTransform(no, q))
            local filename = form.filename and ('%q'):format(form.filename) or "nil"
            -- Constructing a list and then adding file/line data to it triggers a
            -- bug where it changes the value of # for lists that contain nils in
            -- them; constructing the list all in one go with the source data and
            -- contents is how we construct lists in the parser and works around
            -- this problem; allowing # to work in a way that lets us see the nils.
            return ("setmetatable({filename=%s, line=%s, bytestart=%s, %s}" ..
                        ", getmetatable(list()))")
                :format(filename, form.line or "nil", form.bytestart or "nil",
                        mixedConcat(mapped, ", "))
        -- table
        elseif type(form) == 'table' then
            local mapped = utils.kvmap(form, entryTransform(q, q))
            local source = getmetatable(form)
            local filename = source.filename and ('%q'):format(source.filename) or "nil"
            return ("setmetatable({%s}, {filename=%s, line=%s})"):
                format(mixedConcat(mapped, ", "), filename, source and source.line or "nil")
        -- string
        elseif type(form) == 'string' then
            return serializeString(form)
        else
            return tostring(form)
        end
    end
    return {
        -- compiling functions:
        compileString=compileString, compileStream=compileStream,
        compile=compile, compile1=compile1, emit=emit, destructure=destructure,

        -- AST functions:
        gensym=gensym, autogensym=autogensym, doQuote=doQuote,
        macroexpand=macroexpand, globalUnmangling=globalUnmangling,
        applyManglings=applyManglings, globalMangling=globalMangling,

        -- scope functions:
        makeScope=makeScope, keepSideEffects=keepSideEffects,
        declareLocal=declareLocal, symbolToExpression=symbolToExpression,

        -- general functions:
        assert=assertCompile, metadata=makeMetadata(), traceback=traceback,
        scopes=scopes,
    }
end)()

--
-- Specials and macros
--

local specials = (function()
    local SPECIALS = compiler.scopes.global.specials

    -- Convert a fennel environment table to a Lua environment table.
    -- This means automatically unmangling globals when getting a value,
    -- and mangling values when setting a value. This means the original env
    -- will see its values updated as expected, regardless of mangling rules.
    local function wrapEnv(env)
        return setmetatable({}, {
            __index = function(_, key)
                if type(key) == 'string' then
                    key = compiler.globalUnmangling(key)
                end
                return env[key]
            end,
            __newindex = function(_, key, value)
                if type(key) == 'string' then
                    key = compiler.globalMangling(key)
                end
                env[key] = value
            end,
            -- checking the __pairs metamethod won't work automatically in Lua 5.1
            -- sadly, but it's important for 5.2+ and can be done manually in 5.1
            __pairs = function()
                local function putenv(k, v)
                    return type(k) == 'string' and compiler.globalUnmangling(k) or k, v
                end
                local pt = utils.kvmap(env, putenv)
                return next, pt, nil
            end,
        })
    end

    local function currentGlobalNames(env)
        return utils.kvmap(env or _G, compiler.globalUnmangling)
    end

    -- Load code with an environment in all recent Lua versions
    local function loadCode(code, environment, filename)
        environment = environment or _ENV or _G
        if setfenv and loadstring then
            local f = assert(loadstring(code, filename))
            setfenv(f, environment)
            return f
        else
            return assert(load(code, filename, "t", environment))
        end
    end

    -- Return a docstring
    local doc = function(tgt, name)
        if(not tgt) then return name .. " not found" end
        local docstring = (compiler.metadata:get(tgt, 'fnl/docstring') or
                               '#<undocumented>'):gsub('\n$', ''):gsub('\n', '\n  ')
        if type(tgt) == "function" then
            local arglist = table.concat(compiler.metadata:get(tgt, 'fnl/arglist') or
                                             {'#<unknown-arguments>'}, ' ')
            return string.format("(%s%s%s)\n  %s", name, #arglist > 0 and ' ' or '',
                                 arglist, docstring)
        else
            return string.format("%s\n  %s", name, docstring)
        end
    end

    local function docSpecial(name, arglist, docstring)
        compiler.metadata[SPECIALS[name]] =
            { ["fnl/docstring"] = docstring, ["fnl/arglist"] = arglist }
    end

    -- Compile a list of forms for side effects
    local function compileDo(ast, scope, parent, start)
        start = start or 2
        local len = #ast
        local subScope = compiler.makeScope(scope)
        for i = start, len do
            compiler.compile1(ast[i], subScope, parent, {
                nval = 0
            })
        end
    end

    -- Implements a do statement, starting at the 'start' element. By default, start is 2.
    local function doImpl(ast, scope, parent, opts, start, chunk, subScope, preSyms)
        start = start or 2
        subScope = subScope or compiler.makeScope(scope)
        chunk = chunk or {}
        local len = #ast
        local outerTarget = opts.target
        local outerTail = opts.tail
        local retexprs = {returned = true}

        -- See if we need special handling to get the return values
        -- of the do block
        if not outerTarget and opts.nval ~= 0 and not outerTail then
            if opts.nval then
                -- Generate a local target
                local syms = {}
                for i = 1, opts.nval do
                    local s = preSyms and preSyms[i] or compiler.gensym(scope)
                    syms[i] = s
                    retexprs[i] = utils.expr(s, 'sym')
                end
                outerTarget = table.concat(syms, ', ')
                compiler.emit(parent, ('local %s'):format(outerTarget), ast)
                compiler.emit(parent, 'do', ast)
            else
                -- We will use an IIFE for the do
                local fname = compiler.gensym(scope)
                local fargs = scope.vararg and '...' or ''
                compiler.emit(parent, ('local function %s(%s)'):format(fname, fargs), ast)
                retexprs = utils.expr(fname .. '(' .. fargs .. ')', 'statement')
                outerTail = true
                outerTarget = nil
            end
        else
            compiler.emit(parent, 'do', ast)
        end
        -- Compile the body
        if start > len then
            -- In the unlikely case we do a do with no arguments.
            compiler.compile1(nil, subScope, chunk, {
                tail = outerTail,
                target = outerTarget
            })
            -- There will be no side effects
        else
            for i = start, len do
                local subopts = {
                    nval = i ~= len and 0 or opts.nval,
                    tail = i == len and outerTail or nil,
                    target = i == len and outerTarget or nil
                }
                utils.propagateOptions(opts, subopts)
                local subexprs = compiler.compile1(ast[i], subScope, chunk, subopts)
                if i ~= len then
                    compiler.keepSideEffects(subexprs, parent, nil, ast[i])
                end
            end
        end
        compiler.emit(parent, chunk, ast)
        compiler.emit(parent, 'end', ast)
        return retexprs
    end

    SPECIALS["do"] = doImpl
    docSpecial("do", {"..."}, "Evaluate multiple forms; return last value.")

    -- Unlike most expressions and specials, 'values' resolves with multiple
    -- values, one for each argument, allowing multiple return values. The last
    -- expression can return multiple arguments as well, allowing for more than
    -- the number of expected arguments.
    SPECIALS["values"] = function(ast, scope, parent)
        local len = #ast
        local exprs = {}
        for i = 2, len do
            local subexprs = compiler.compile1(ast[i], scope, parent, {
                nval = (i ~= len) and 1
            })
            exprs[#exprs + 1] = subexprs[1]
            if i == len then
                for j = 2, #subexprs do
                    exprs[#exprs + 1] = subexprs[j]
                end
            end
        end
        return exprs
    end
    docSpecial("values", {"..."},
               "Return multiple values from a function.  Must be in tail position.")

    -- The fn special declares a function. Syntax is similar to other lisps;
    -- (fn optional-name [arg ...] (body))
    -- Further decoration such as docstrings, meta info, and multibody functions a possibility.
    SPECIALS["fn"] = function(ast, scope, parent)
        local fScope = compiler.makeScope(scope)
        local fChunk = {}
        local index = 2
        local fnName = utils.isSym(ast[index])
        local isLocalFn
        local docstring
        fScope.vararg = false
        local multi = fnName and utils.isMultiSym(fnName[1])
        compiler.assert(not multi or not multi.multiSymMethodCall,
                      "unexpected multi symbol " .. tostring(fnName), ast[index])
        if fnName and fnName[1] ~= 'nil' then
            isLocalFn = not multi
            if isLocalFn then
                fnName = compiler.declareLocal(fnName, {}, scope, ast)
            else
                fnName = compiler.symbolToExpression(fnName, scope)[1]
            end
            index = index + 1
        else
            isLocalFn = true
            fnName = compiler.gensym(scope)
        end
        local argList = compiler.assert(utils.isTable(ast[index]),
                                      "expected parameters",
                                      type(ast[index]) == "table" and ast[index] or ast)
        local function getArgName(i, name)
            if utils.isVarg(name) then
                compiler.assert(i == #argList, "expected vararg as last parameter", ast[2])
                fScope.vararg = true
                return "..."
            elseif(utils.isSym(name) and utils.deref(name) ~= "nil"
                   and not utils.isMultiSym(utils.deref(name))) then
                return compiler.declareLocal(name, {}, fScope, ast)
            elseif utils.isTable(name) then
                local raw = utils.sym(compiler.gensym(scope))
                local declared = compiler.declareLocal(raw, {}, fScope, ast)
                compiler.destructure(name, raw, ast, fScope, fChunk,
                                     { declaration = true, nomulti = true })
                return declared
            else
                compiler.assert(false, ("expected symbol for function parameter: %s"):
                                  format(tostring(name)), ast[2])
            end
        end
        local argNameList = utils.kvmap(argList, getArgName)
        if type(ast[index + 1]) == 'string' and index + 1 < #ast then
            index = index + 1
            docstring = ast[index]
        end
        for i = index + 1, #ast do
            compiler.compile1(ast[i], fScope, fChunk, {
                tail = i == #ast,
                nval = i ~= #ast and 0 or nil,
            })
        end
        if isLocalFn then
            compiler.emit(parent, ('local function %s(%s)')
                     :format(fnName, table.concat(argNameList, ', ')), ast)
        else
            compiler.emit(parent, ('%s = function(%s)')
                     :format(fnName, table.concat(argNameList, ', ')), ast)
        end

        compiler.emit(parent, fChunk, ast)
        compiler.emit(parent, 'end', ast)

        if utils.root.options.useMetadata then
            local args = utils.map(argList, function(v)
                -- TODO: show destructured args properly instead of replacing
                return utils.isTable(v) and '"#<table>"' or string.format('"%s"', tostring(v))
            end)

            local metaFields = {
                '"fnl/arglist"', '{' .. table.concat(args, ', ') .. '}',
            }
            if docstring then
                table.insert(metaFields, '"fnl/docstring"')
                table.insert(metaFields, '"' .. docstring:gsub('%s+$', '')
                                 :gsub('\\', '\\\\'):gsub('\n', '\\n')
                                 :gsub('"', '\\"') .. '"')
            end
            local metaStr = ('require("%s").metadata'):
                format(utils.root.options.moduleName or "fennel")
            compiler.emit(parent, string.format('pcall(function() %s:setall(%s, %s) end)',
                                       metaStr, fnName, table.concat(metaFields, ', ')))
        end

        return utils.expr(fnName, 'sym')
    end
    docSpecial("fn", {"name?", "args", "docstring?", "..."},
               "Function syntax. May optionally include a name and docstring."
                   .."\nIf a name is provided, the function will be bound in the current scope."
                   .."\nWhen called with the wrong number of args, excess args will be discarded"
                   .."\nand lacking args will be nil, use lambda for arity-checked functions.")

    -- (lua "print('hello!')") -> prints hello, evaluates to nil
    -- (lua "print 'hello!'" "10") -> prints hello, evaluates to the number 10
    -- (lua nil "{1,2,3}") -> Evaluates to a table literal
    SPECIALS['lua'] = function(ast, _, parent)
        compiler.assert(#ast == 2 or #ast == 3, "expected 1 or 2 arguments", ast)
        if ast[2] ~= nil then
            table.insert(parent, {leaf = tostring(ast[2]), ast = ast})
        end
        if #ast == 3 then
            return tostring(ast[3])
        end
    end

    SPECIALS['doc'] = function(ast, scope, parent)
        assert(utils.root.options.useMetadata, "can't look up doc with metadata disabled.")
        compiler.assert(#ast == 2, "expected one argument", ast)

        local target = utils.deref(ast[2])
        local specialOrMacro = scope.specials[target] or scope.macros[target]
        if specialOrMacro then
            return ("print([[%s]])"):format(doc(specialOrMacro, target))
        else
            local value = tostring(compiler.compile1(ast[2], scope, parent, {nval = 1})[1])
            -- need to require here since the metadata is stored in the module
            -- and we need to make sure we look it up in the same module it was
            -- declared from.
            return ("print(require('%s').doc(%s, '%s'))")
                :format(utils.root.options.moduleName or "fennel", value, tostring(ast[2]))
        end
    end
    docSpecial("doc", {"x"},
               "Print the docstring and arglist for a function, macro, or special form.")

    -- Table lookup
    SPECIALS["."] = function(ast, scope, parent)
        local len = #ast
        compiler.assert(len > 1, "expected table argument", ast)
        local lhs = compiler.compile1(ast[2], scope, parent, {nval = 1})
        if len == 2 then
            return tostring(lhs[1])
        else
            local indices = {}
            for i = 3, len do
                local index = ast[i]
                if type(index) == 'string' and utils.isValidLuaIdentifier(index) then
                    table.insert(indices, '.' .. index)
                else
                    index = compiler.compile1(index, scope, parent, {nval = 1})[1]
                    table.insert(indices, '[' .. tostring(index) .. ']')
                end
            end
            -- extra parens are needed for table literals
            if utils.isTable(ast[2]) then
                return '(' .. tostring(lhs[1]) .. ')' .. table.concat(indices)
            else
                return tostring(lhs[1]) .. table.concat(indices)
            end
        end
    end
    docSpecial(".", {"tbl", "key1", "..."},
               "Look up key1 in tbl table. If more args are provided, do a nested lookup.")

    SPECIALS["global"] = function(ast, scope, parent)
        compiler.assert(#ast == 3, "expected name and value", ast)
        compiler.destructure(ast[2], ast[3], ast, scope, parent, {
            nomulti = true,
            forceglobal = true
        })
    end
    docSpecial("global", {"name", "val"}, "Set name as a global with val.")

    SPECIALS["set"] = function(ast, scope, parent)
        compiler.assert(#ast == 3, "expected name and value", ast)
        compiler.destructure(ast[2], ast[3], ast, scope, parent, {
            noundef = true
        })
    end
    docSpecial("set", {"name", "val"},
               "Set a local variable to a new value. Only works on locals using var.")

    SPECIALS["set-forcibly!"] = function(ast, scope, parent)
        compiler.assert(#ast == 3, "expected name and value", ast)
        compiler.destructure(ast[2], ast[3], ast, scope, parent, {
            forceset = true
        })
    end

    SPECIALS["local"] = function(ast, scope, parent)
        compiler.assert(#ast == 3, "expected name and value", ast)
        compiler.destructure(ast[2], ast[3], ast, scope, parent, {
            declaration = true,
            nomulti = true
        })
    end
    docSpecial("local", {"name", "val"},
               "Introduce new top-level immutable local.")

    SPECIALS["var"] = function(ast, scope, parent)
        compiler.assert(#ast == 3, "expected name and value", ast)
        compiler.destructure(ast[2], ast[3], ast, scope, parent, {
                                 declaration = true, nomulti = true, isvar = true })
    end
    docSpecial("var", {"name", "val"},
               "Introduce new mutable local.")

    SPECIALS["let"] = function(ast, scope, parent, opts)
        local bindings = ast[2]
        compiler.assert(utils.isList(bindings) or utils.isTable(bindings),
                      "expected binding table", ast)
        compiler.assert(#bindings % 2 == 0,
                      "expected even number of name/value bindings", ast[2])
        compiler.assert(#ast >= 3, "expected body expression", ast[1])
        -- we have to gensym the binding for the let body's return value before
        -- compiling the binding vector, otherwise there's a possibility to conflict
        local preSyms = {}
        for _ = 1, (opts.nval or 0) do table.insert(preSyms, compiler.gensym(scope)) end
        local subScope = compiler.makeScope(scope)
        local subChunk = {}
        for i = 1, #bindings, 2 do
            compiler.destructure(bindings[i], bindings[i + 1], ast, subScope, subChunk, {
                                     declaration = true, nomulti = true })
        end
        return doImpl(ast, scope, parent, opts, 3, subChunk, subScope, preSyms)
    end
    docSpecial("let", {"[name1 val1 ... nameN valN]", "..."},
               "Introduces a new scope in which a given set of local bindings are used.")

    -- For setting items in a table
    SPECIALS["tset"] = function(ast, scope, parent)
        compiler.assert(#ast > 3, ("expected table, key, and value arguments"), ast)
        local root = compiler.compile1(ast[2], scope, parent, {nval = 1})[1]
        local keys = {}
        for i = 3, #ast - 1 do
            local key = compiler.compile1(ast[i], scope, parent, {nval = 1})[1]
            keys[#keys + 1] = tostring(key)
        end
        local value = compiler.compile1(ast[#ast], scope, parent, {nval = 1})[1]
        local rootstr = tostring(root)
        -- Prefix 'do end ' so parens are not ambiguous (grouping or function call?)
        local fmtstr = (rootstr:match("^{")) and "do end (%s)[%s] = %s" or "%s[%s] = %s"
        compiler.emit(parent, fmtstr:format(tostring(root),
                                   table.concat(keys, ']['),
                                   tostring(value)), ast)
    end
    docSpecial("tset", {"tbl", "key1", "...", "keyN", "val"},
               "Set the value of a table field. Can take additional keys to set"
            .. "nested values,\nbut all parents must contain an existing table.")

    -- The if special form behaves like the cond form in
    -- many languages
    SPECIALS["if"] = function(ast, scope, parent, opts)
        local doScope = compiler.makeScope(scope)
        local branches = {}
        local elseBranch = nil

        -- Calculate some external stuff. Optimizes for tail calls and what not
        local wrapper, innerTail, innerTarget, targetExprs
        if opts.tail or opts.target or opts.nval then
            if opts.nval and opts.nval ~= 0 and not opts.target then
                -- We need to create a target
                targetExprs = {}
                local accum = {}
                for i = 1, opts.nval do
                    local s = compiler.gensym(scope)
                    accum[i] = s
                    targetExprs[i] = utils.expr(s, 'sym')
                end
                wrapper = 'target'
                innerTail = opts.tail
                innerTarget = table.concat(accum, ', ')
            else
                wrapper = 'none'
                innerTail = opts.tail
                innerTarget = opts.target
            end
        else
            wrapper = 'iife'
            innerTail = true
            innerTarget = nil
        end

        -- Compile bodies and conditions
        local bodyOpts = {
            tail = innerTail,
            target = innerTarget,
            nval = opts.nval
        }
        local function compileBody(i)
            local chunk = {}
            local cscope = compiler.makeScope(doScope)
            compiler.keepSideEffects(compiler.compile1(ast[i], cscope, chunk, bodyOpts),
            chunk, nil, ast[i])
            return {
                chunk = chunk,
                scope = cscope
            }
        end
        for i = 2, #ast - 1, 2 do
            local condchunk = {}
            local res = compiler.compile1(ast[i], doScope, condchunk, {nval = 1})
            local cond = res[1]
            local branch = compileBody(i + 1)
            branch.cond = cond
            branch.condchunk = condchunk
            branch.nested = i ~= 2 and next(condchunk, nil) == nil
            table.insert(branches, branch)
        end
        local hasElse = #ast > 3 and #ast % 2 == 0
        if hasElse then elseBranch = compileBody(#ast) end

        -- Emit code
        local s = compiler.gensym(scope)
        local buffer = {}
        local lastBuffer = buffer
        for i = 1, #branches do
            local branch = branches[i]
            local fstr = not branch.nested and 'if %s then' or 'elseif %s then'
            local cond = tostring(branch.cond)
            local condLine = (cond == "true" and branch.nested and i == #branches)
                and "else"
                or fstr:format(cond)
            if branch.nested then
                compiler.emit(lastBuffer, branch.condchunk, ast)
            else
                for _, v in ipairs(branch.condchunk) do compiler.emit(lastBuffer, v, ast) end
            end
            compiler.emit(lastBuffer, condLine, ast)
            compiler.emit(lastBuffer, branch.chunk, ast)
            if i == #branches then
                if hasElse then
                    compiler.emit(lastBuffer, 'else', ast)
                    compiler.emit(lastBuffer, elseBranch.chunk, ast)
                -- TODO: Consolidate use of condLine ~= "else" with hasElse
                elseif(innerTarget and condLine ~= 'else') then
                    compiler.emit(lastBuffer, 'else', ast)
                    compiler.emit(lastBuffer, ("%s = nil"):format(innerTarget), ast)
                end
                compiler.emit(lastBuffer, 'end', ast)
            elseif not branches[i + 1].nested then
                compiler.emit(lastBuffer, 'else', ast)
                local nextBuffer = {}
                compiler.emit(lastBuffer, nextBuffer, ast)
                compiler.emit(lastBuffer, 'end', ast)
                lastBuffer = nextBuffer
            end
        end

        if wrapper == 'iife' then
            local iifeargs = scope.vararg and '...' or ''
            compiler.emit(parent, ('local function %s(%s)'):format(tostring(s), iifeargs), ast)
            compiler.emit(parent, buffer, ast)
            compiler.emit(parent, 'end', ast)
            return utils.expr(('%s(%s)'):format(tostring(s), iifeargs), 'statement')
        elseif wrapper == 'none' then
            -- Splice result right into code
            for i = 1, #buffer do
                compiler.emit(parent, buffer[i], ast)
            end
            return {returned = true}
        else -- wrapper == 'target'
            compiler.emit(parent, ('local %s'):format(innerTarget), ast)
            for i = 1, #buffer do
                compiler.emit(parent, buffer[i], ast)
            end
            return targetExprs
        end
    end
    docSpecial("if", {"cond1", "body1", "...", "condN", "bodyN"},
               "Conditional form.\n" ..
                   "Takes any number of condition/body pairs and evaluates the first body where"
                   .. "\nthe condition evaluates to truthy. Similar to cond in other lisps.")

    -- (each [k v (pairs t)] body...) => []
    SPECIALS["each"] = function(ast, scope, parent)
        local binding = compiler.assert(utils.isTable(ast[2]), "expected binding table", ast)
        compiler.assert(#ast >= 3, "expected body expression", ast[1])
        local iter = table.remove(binding, #binding) -- last item is iterator call
        local destructures = {}
        local newManglings = {}
        local subScope = compiler.makeScope(scope)
        local function destructureBinding(v)
            if utils.isSym(v) then
                return compiler.declareLocal(v, {}, subScope, ast, newManglings)
            else
                local raw = utils.sym(compiler.gensym(subScope))
                destructures[raw] = v
                return compiler.declareLocal(raw, {}, subScope, ast)
            end
        end
        local bindVars = utils.map(binding, destructureBinding)
        local vals = compiler.compile1(iter, subScope, parent)
        local valNames = utils.map(vals, tostring)

        compiler.emit(parent, ('for %s in %s do'):format(table.concat(bindVars, ', '),
                                                table.concat(valNames, ", ")), ast)
        local chunk = {}
        for raw, args in utils.stablepairs(destructures) do
            compiler.destructure(args, raw, ast, subScope, chunk,
                                 { declaration = true, nomulti = true })
        end
        compiler.applyManglings(subScope, newManglings, ast)
        compileDo(ast, subScope, chunk, 3)
        compiler.emit(parent, chunk, ast)
        compiler.emit(parent, 'end', ast)
    end
    docSpecial("each", {"[key value (iterator)]", "..."},
               "Runs the body once for each set of values provided by the given iterator."
               .."\nMost commonly used with ipairs for sequential tables or pairs for"
                   .." undefined\norder, but can be used with any iterator.")

    -- (while condition body...) => []
    SPECIALS["while"] = function(ast, scope, parent)
        local len1 = #parent
        local condition = compiler.compile1(ast[2], scope, parent, {nval = 1})[1]
        local len2 = #parent
        local subChunk = {}
        if len1 ~= len2 then
            -- Compound condition
            -- Move new compilation to subchunk
            for i = len1 + 1, len2 do
                subChunk[#subChunk + 1] = parent[i]
                parent[i] = nil
            end
            compiler.emit(parent, 'while true do', ast)
            compiler.emit(subChunk, ('if not %s then break end'):format(condition[1]), ast)
        else
            -- Simple condition
            compiler.emit(parent, 'while ' .. tostring(condition) .. ' do', ast)
        end
        compileDo(ast, compiler.makeScope(scope), subChunk, 3)
        compiler.emit(parent, subChunk, ast)
        compiler.emit(parent, 'end', ast)
    end
    docSpecial("while", {"condition", "..."},
               "The classic while loop. Evaluates body until a condition is non-truthy.")

    SPECIALS["for"] = function(ast, scope, parent)
        local ranges = compiler.assert(utils.isTable(ast[2]), "expected binding table", ast)
        local bindingSym = table.remove(ast[2], 1)
        local subScope = compiler.makeScope(scope)
        compiler.assert(utils.isSym(bindingSym),
                      ("unable to bind %s %s"):
                          format(type(bindingSym), tostring(bindingSym)), ast[2])
        compiler.assert(#ast >= 3, "expected body expression", ast[1])
        local rangeArgs = {}
        for i = 1, math.min(#ranges, 3) do
            rangeArgs[i] = tostring(compiler.compile1(ranges[i], subScope, parent, {nval = 1})[1])
        end
        compiler.emit(parent, ('for %s = %s do'):format(
                 compiler.declareLocal(bindingSym, {}, subScope, ast),
                 table.concat(rangeArgs, ', ')), ast)
        local chunk = {}
        compileDo(ast, subScope, chunk, 3)
        compiler.emit(parent, chunk, ast)
        compiler.emit(parent, 'end', ast)
    end
    docSpecial("for", {"[index start stop step?]", "..."}, "Numeric loop construct." ..
                   "\nEvaluates body once for each value between start and stop (inclusive).")

    -- For statements and expressions, put the value in a local to avoid
    -- double-evaluating it.
    local function once(val, ast, scope, parent)
        if val.type == 'statement' or val.type == 'expression' then
            local s = compiler.gensym(scope)
            compiler.emit(parent, ('local %s = %s'):format(s, tostring(val)), ast)
            return utils.expr(s, 'sym')
        else
            return val
        end
    end

    SPECIALS[":"] = function(ast, scope, parent)
        compiler.assert(#ast >= 3, "expected at least 2 arguments", ast)
        -- Compile object
        local objectexpr = compiler.compile1(ast[2], scope, parent, {nval = 1})[1]
        -- Compile method selector
        local methodstring
        local methodident = false
        if type(ast[3]) == 'string' and utils.isValidLuaIdentifier(ast[3]) then
            methodident = true
            methodstring = ast[3]
        else
            methodstring = tostring(compiler.compile1(ast[3], scope, parent, {nval = 1})[1])
            objectexpr = once(objectexpr, ast[2], scope, parent)
        end
        -- Compile arguments
        local args = {}
        for i = 4, #ast do
            local subexprs = compiler.compile1(ast[i], scope, parent, {
                nval = i ~= #ast and 1 or nil
            })
            utils.map(subexprs, tostring, args)
        end
        local fstring
        if not methodident then
            -- Make object first argument
            table.insert(args, 1, tostring(objectexpr))
            fstring = objectexpr.type == 'sym'
                and '%s[%s](%s)'
                or '(%s)[%s](%s)'
        elseif(objectexpr.type == 'literal' or objectexpr.type == 'expression') then
            fstring = '(%s):%s(%s)'
        else
            fstring = '%s:%s(%s)'
        end
        return utils.expr(fstring:format(
            tostring(objectexpr),
            methodstring,
            table.concat(args, ', ')), 'statement')
    end
    docSpecial(":", {"tbl", "method-name", "..."},
               "Call the named method on tbl with the provided args."..
               "\nMethod name doesn\"t have to be known at compile-time; if it is, use"
                   .."\n(tbl:method-name ...) instead.")

    SPECIALS["comment"] = function(ast, _, parent)
        local els = {}
        for i = 2, #ast do
            els[#els + 1] = tostring(ast[i]):gsub('\n', ' ')
        end
        compiler.emit(parent, '-- ' .. table.concat(els, ' '), ast)
    end
    docSpecial("comment", {"..."}, "Comment which will be emitted in Lua output.")

    SPECIALS["hashfn"] = function(ast, scope, parent)
        compiler.assert(#ast == 2, "expected one argument", ast)
        local fScope = compiler.makeScope(scope)
        local fChunk = {}
        local name = compiler.gensym(scope)
        local symbol = utils.sym(name)
        compiler.declareLocal(symbol, {}, scope, ast)
        fScope.vararg = false
        fScope.hashfn = true
        local args = {}
        for i = 1, 9 do args[i] = compiler.declareLocal(utils.sym('$' .. i), {}, fScope, ast) end
        -- Compile body
        compiler.compile1(ast[2], fScope, fChunk, {tail = true})
        local maxUsed = 0
        for i = 1, 9 do if fScope.symmeta['$' .. i].used then maxUsed = i end end
        local argStr = table.concat(args, ', ', 1, maxUsed)
        compiler.emit(parent, ('local function %s(%s)'):format(name, argStr), ast)
        compiler.emit(parent, fChunk, ast)
        compiler.emit(parent, 'end', ast)
        return utils.expr(name, 'sym')
    end
    docSpecial("hashfn", {"..."}, "Function literal shorthand; args are $1, $2, etc.")

    local function defineArithmeticSpecial(name, zeroArity, unaryPrefix, luaName)
        local paddedOp = ' ' .. (luaName or name) .. ' '
        SPECIALS[name] = function(ast, scope, parent)
            local len = #ast
            if len == 1 then
                compiler.assert(zeroArity ~= nil, 'Expected more than 0 arguments', ast)
                return utils.expr(zeroArity, 'literal')
            else
                local operands = {}
                for i = 2, len do
                    local subexprs = compiler.compile1(ast[i], scope, parent, {
                        nval = (i == 1 and 1 or nil)
                    })
                    utils.map(subexprs, tostring, operands)
                end
                if #operands == 1 then
                    if unaryPrefix then
                        return '(' .. unaryPrefix .. paddedOp .. operands[1] .. ')'
                    else
                        return operands[1]
                    end
                else
                    return '(' .. table.concat(operands, paddedOp) .. ')'
                end
            end
        end
        docSpecial(name, {"a", "b", "..."},
                   "Arithmetic operator; works the same as Lua but accepts more arguments.")
    end

    defineArithmeticSpecial('+', '0')
    defineArithmeticSpecial('..', "''")
    defineArithmeticSpecial('^')
    defineArithmeticSpecial('-', nil, '')
    defineArithmeticSpecial('*', '1')
    defineArithmeticSpecial('%')
    defineArithmeticSpecial('/', nil, '1')
    defineArithmeticSpecial('//', nil, '1')

    defineArithmeticSpecial("lshift", nil, "1", "<<")
    defineArithmeticSpecial("rshift", nil, "1", ">>")
    defineArithmeticSpecial("band", "0", "0", "&")
    defineArithmeticSpecial("bor", "0", "0", "|")
    defineArithmeticSpecial("bxor", "0", "0", "~")

    docSpecial("lshift", {"x", "n"},
               "Bitwise logical left shift of x by n bits; only works in Lua 5.3+.")
    docSpecial("rshift", {"x", "n"},
               "Bitwise logical right shift of x by n bits; only works in Lua 5.3+.")
    docSpecial("band", {"x1", "x2"}, "Bitwise AND of arguments; only works in Lua 5.3+.")
    docSpecial("bor", {"x1", "x2"}, "Bitwise OR of arguments; only works in Lua 5.3+.")
    docSpecial("bxor", {"x1", "x2"}, "Bitwise XOR of arguments; only works in Lua 5.3+.")

    defineArithmeticSpecial('or', 'false')
    defineArithmeticSpecial('and', 'true')

    docSpecial("and", {"a", "b", "..."},
               "Boolean operator; works the same as Lua but accepts more arguments.")
    docSpecial("or", {"a", "b", "..."},
               "Boolean operator; works the same as Lua but accepts more arguments.")
    docSpecial("..", {"a", "b", "..."},
               "String concatenation operator; works the same as Lua but accepts more arguments.")

    local function defineComparatorSpecial(name, realop, chainOp)
        local op = realop or name
        SPECIALS[name] = function(ast, scope, parent)
            local len = #ast
            compiler.assert(len > 2, "expected at least two arguments", ast)
            local lhs = compiler.compile1(ast[2], scope, parent, {nval = 1})[1]
            local lastval = compiler.compile1(ast[3], scope, parent, {nval = 1})[1]
            -- avoid double-eval by introducing locals for possible side-effects
            if len > 3 then lastval = once(lastval, ast[3], scope, parent) end
            local out = ('(%s %s %s)'):
                format(tostring(lhs), op, tostring(lastval))
            if len > 3 then
                for i = 4, len do -- variadic comparison
                    local nextval = once(compiler.compile1(ast[i], scope, parent, {nval = 1})[1],
                                         ast[i], scope, parent)
                    out = (out .. " %s (%s %s %s)"):
                        format(chainOp or 'and', tostring(lastval), op, tostring(nextval))
                    lastval = nextval
                end
                out = '(' .. out .. ')'
            end
            return out
        end
        docSpecial(name, {"a", "b", "..."},
                   "Comparison operator; works the same as Lua but accepts more arguments.")
    end

    defineComparatorSpecial('>')
    defineComparatorSpecial('<')
    defineComparatorSpecial('>=')
    defineComparatorSpecial('<=')
    defineComparatorSpecial('=', '==')
    defineComparatorSpecial('not=', '~=', 'or')
    SPECIALS["~="] = SPECIALS["not="] -- backwards-compatibility alias

    local function defineUnarySpecial(op, realop)
        SPECIALS[op] = function(ast, scope, parent)
            compiler.assert(#ast == 2, 'expected one argument', ast)
            local tail = compiler.compile1(ast[2], scope, parent, {nval = 1})
            return (realop or op) .. tostring(tail[1])
        end
    end

    defineUnarySpecial("not", "not ")
    docSpecial("not", {"x"}, "Logical operator; works the same as Lua.")

    defineUnarySpecial("bnot", "~")
    docSpecial("bnot", {"x"}, "Bitwise negation; only works in Lua 5.3+.")

    defineUnarySpecial("length", "#")
    docSpecial("length", {"x"}, "Returns the length of a table or string.")
    SPECIALS["#"] = SPECIALS["length"]

    SPECIALS['quote'] = function(ast, scope, parent)
        compiler.assert(#ast == 2, "expected one argument")
        local runtime, thisScope = true, scope
        while thisScope do
            thisScope = thisScope.parent
            if thisScope == compiler.scopes.compiler then runtime = false end
        end
        return compiler.doQuote(ast[2], scope, parent, runtime)
    end
    docSpecial('quote', {'x'}, 'Quasiquote the following form. Only works in macro/compiler scope.')

    local function makeCompilerEnv(ast, scope, parent)
        return setmetatable({
            -- State of compiler if needed
            _SCOPE = scope,
            _CHUNK = parent,
            _AST = ast,
            _IS_COMPILER = true,
            _SPECIALS = compiler.scopes.global.specials,
            _VARARG = utils.varg(),
            -- Expose the module in the compiler
            fennel = utils.fennelModule,
            unpack = unpack,

            -- Useful for macros and meta programming. All of Fennel can be accessed
            -- via fennel.myfun, for example (fennel.eval "(print 1)").
            list = utils.list,
            sym = utils.sym,
            sequence = utils.sequence,
            gensym = function()
                return utils.sym(compiler.gensym(compiler.scopes.macro or scope))
            end,
            ["list?"] = utils.isList,
            ["multi-sym?"] = utils.isMultiSym,
            ["sym?"] = utils.isSym,
            ["table?"] = utils.isTable,
            ["sequence?"] = utils.isSequence,
            ["varg?"] = utils.isVarg,
            ["get-scope"] = function() return compiler.scopes.macro end,
            ["in-scope?"] = function(symbol)
                compiler.assert(compiler.scopes.macro, "must call from macro", ast)
                return compiler.scopes.macro.manglings[tostring(symbol)]
            end,
            ["macroexpand"] = function(form)
                compiler.assert(compiler.scopes.macro, "must call from macro", ast)
                return compiler.macroexpand(form, compiler.scopes.macro)
            end,
        }, { __index = _ENV or _G })
    end

    -- have searchModule use package.config to process package.path (windows compat)
    local cfg = string.gmatch(package.config, "([^\n]+)")
    local dirsep, pathsep, pathmark = cfg() or '/', cfg() or ';', cfg() or '?'
    local pkgConfig = {dirsep = dirsep, pathsep = pathsep, pathmark = pathmark}

    -- Escape a string for safe use in a Lua pattern
    local function escapepat(str)
        return string.gsub(str, "[^%w]", "%%%1")
    end

    local function searchModule(modulename, pathstring)
        local pathsepesc = escapepat(pkgConfig.pathsep)
        local pathsplit = string.format("([^%s]*)%s", pathsepesc,
                                        escapepat(pkgConfig.pathsep))
        local nodotModule = modulename:gsub("%.", pkgConfig.dirsep)
        for path in string.gmatch((pathstring or utils.path) ..
                                  pkgConfig.pathsep, pathsplit) do
            local filename = path:gsub(escapepat(pkgConfig.pathmark), nodotModule)
            local filename2 = path:gsub(escapepat(pkgConfig.pathmark), modulename)
            local file = io.open(filename) or io.open(filename2)
            if(file) then
                file:close()
                return filename
            end
        end
    end

    local function macroGlobals(env, globals)
        local allowed = currentGlobalNames(env)
        for _, k in pairs(globals or {}) do table.insert(allowed, k) end
        return allowed
    end

    local function addMacros(macros, ast, scope)
        compiler.assert(utils.isTable(macros), 'expected macros to be table', ast)
        for k,v in pairs(macros) do
            compiler.assert(type(v) == 'function', 'expected each macro to be function', ast)
            scope.macros[k] = v
        end
    end

    local function loadMacros(modname, ast, scope, parent)
        local filename = compiler.assert(searchModule(modname),
                                       modname .. " module not found.", ast)
        local env = makeCompilerEnv(ast, scope, parent)
        local globals = macroGlobals(env, currentGlobalNames())
        return compiler.dofileFennel(filename,
                                     { env = env, allowedGlobals = globals,
                                       useMetadata = utils.root.options.useMetadata,
                                       scope = compiler.scopes.compiler })
    end

    local macroLoaded = {}

    SPECIALS['require-macros'] = function(ast, scope, parent)
        compiler.assert(#ast == 2, "Expected one module name argument", ast)
        local modname = ast[2]
        if not macroLoaded[modname] then
            macroLoaded[modname] = loadMacros(modname, ast, scope, parent)
        end
        addMacros(macroLoaded[modname], ast, scope, parent)
    end
    docSpecial('require-macros', {'macro-module-name'},
               'Load given module and use its contents as macro definitions in current scope.'
                   ..'\nMacro module should return a table of macro functions with string keys.'
                   ..'\nConsider using import-macros instead as it is more flexible.')

    SPECIALS['include'] = function(ast, scope, parent, opts)
        compiler.assert(#ast == 2, 'expected one argument', ast)

        -- Compile mod argument
        local modexpr = compiler.compile1(ast[2], scope, parent, {nval = 1})[1]
        if modexpr.type ~= 'literal' or modexpr[1]:byte() ~= 34 then
            if opts.fallback then
                return opts.fallback(modexpr)
            else
                compiler.assert(false, 'module name must resolve to a string literal', ast)
            end
        end
        local code = 'return ' .. modexpr[1]
        local mod = loadCode(code)()

        -- Check cache
        if utils.root.scope.includes[mod] then return utils.root.scope.includes[mod] end

        -- Find path to source
        local path = searchModule(mod)
        local isFennel = true
        if not path then
            isFennel = false
            path = searchModule(mod, package.path)
            if not path then
                if opts.fallback then
                    return opts.fallback(modexpr)
                else
                    compiler.assert(false, 'module not found ' .. mod, ast)
                end
            end
        end

        -- Read source
        local f = io.open(path)
        local s = f:read('*all'):gsub('[\r\n]*$', '')
        f:close()

        -- splice in source and memoize it in compiler AND package.preload
        -- so we can include it again without duplication, even in runtime
        local ret = utils.expr('require("' .. mod .. '")', 'statement')
        local target = ('package.preload[%q]'):format(mod)
        local preloadStr = target .. ' = ' .. target .. ' or function(...)'

        local tempChunk, subChunk = {}, {}
        compiler.emit(tempChunk, preloadStr, ast)
        compiler.emit(tempChunk, subChunk)
        compiler.emit(tempChunk, 'end', ast)
        -- Splice tempChunk to begining of root chunk
        for i, v in ipairs(tempChunk) do table.insert(utils.root.chunk, i, v) end

        -- For fnl source, compile subChunk AFTER splicing into start of root chunk.
        if isFennel then
            local subscope = compiler.makeScope(utils.root.scope.parent)
            if utils.root.options.requireAsInclude then
                subscope.specials.require = compiler.requireInclude
            end
            -- parse Fennel src into table of exprs to know which expr is the tail
            local forms, p = {}, parser.parser(parser.stringStream(s), path)
            for _, val in p do table.insert(forms, val) end
            -- Compile the forms into subChunk; compiler.compile1 is necessary for all nested
            -- includes to be emitted in the same root chunk in the top-level module
            for i = 1, #forms do
                local subopts = i == #forms and {nval=1, tail=true} or {}
                utils.propagateOptions(opts, subopts)
                compiler.compile1(forms[i], subscope, subChunk, subopts)
            end
        else -- for Lua source, simply emit the src into the loader's body
            compiler.emit(subChunk, s, ast)
        end

        -- Put in cache and return
        utils.root.scope.includes[mod] = ret
        return ret
    end
    docSpecial('include', {'module-name-literal'},
               'Like require, but load the target module during compilation and embed it in the\n'
            .. 'Lua output. The module must be a string literal and resolvable at compile time.')

    local function evalCompiler(ast, scope, parent)
        local luaSource =
            compiler.compile(ast, { scope = compiler.makeScope(compiler.scopes.compiler),
                                    useMetadata = utils.root.options.useMetadata })
        local loader = loadCode(luaSource, wrapEnv(makeCompilerEnv(ast, scope, parent)))
        return loader()
    end

    SPECIALS['macros'] = function(ast, scope, parent)
        compiler.assert(#ast == 2, "Expected one table argument", ast)
        local macros = evalCompiler(ast[2], scope, parent)
        addMacros(macros, ast, scope, parent)
    end
    docSpecial('macros', {'{:macro-name-1 (fn [...] ...) ... :macro-name-N macro-body-N}'},
               'Define all functions in the given table as macros local to the current scope.')

    SPECIALS['eval-compiler'] = function(ast, scope, parent)
        local oldFirst = ast[1]
        ast[1] = utils.sym('do')
        local val = evalCompiler(ast, scope, parent)
        ast[1] = oldFirst
        return val
    end
    docSpecial('eval-compiler', {'...'}, 'Evaluate the body at compile-time.'
                   .. ' Use the macro system instead if possible.')

    -- A few things that aren't specials, but are needed to define specials, but
    -- are also needed for the following code.
    return { wrapEnv=wrapEnv,
             currentGlobalNames=currentGlobalNames,
             loadCode=loadCode,
             doc=doc,
             macroLoaded=macroLoaded,
             searchModule=searchModule,
             makeCompilerEnv=makeCompilerEnv, }
end)()

---
--- Evaluation, repl, public API, and macros
---

local function eval(str, options, ...)
    local opts = utils.copy(options)
    -- eval and dofile are considered "live" entry points, so we can assume
    -- that the globals available at compile time are a reasonable allowed list
    -- UNLESS there's a metatable on env, in which case we can't assume that
    -- pairs will return all the effective globals; for instance openresty
    -- sets up _G in such a way that all the globals are available thru
    -- the __index meta method, but as far as pairs is concerned it's empty.
    if opts.allowedGlobals == nil and not getmetatable(opts.env) then
        opts.allowedGlobals = specials.currentGlobalNames(opts.env)
    end
    local env = opts.env and specials.wrapEnv(opts.env)
    local luaSource = compiler.compileString(str, opts)
    local loader = specials.loadCode(luaSource, env, opts.filename and
                                         ('@' .. opts.filename) or str)
    opts.filename = nil
    return loader(...)
end

-- This is bad; we have a circular dependency between the specials section and
-- the evaluation section due to require-macros/import-macros needing to be able
-- to do this. For now stash it in the compiler table, but we should untangle it
compiler.dofileFennel = function(filename, options, ...)
    local opts = utils.copy(options)
    if opts.allowedGlobals == nil then
        opts.allowedGlobals = specials.currentGlobalNames(opts.env)
    end
    local f = assert(io.open(filename, "rb"))
    local source = f:read("*all")
    f:close()
    opts.filename = filename
    return eval(source, opts, ...)
end

-- Everything exported by the module
local module = {
    parser = parser.parser,
    granulate = parser.granulate,
    stringStream = parser.stringStream,

    compile = compiler.compile,
    compileString = compiler.compileString,
    compileStream = compiler.compileStream,
    compile1 = compiler.compile1,
    traceback = compiler.traceback,
    mangle = compiler.globalMangling,
    unmangle = compiler.globalUnmangling,
    metadata = compiler.metadata,
    scope = compiler.makeScope,
    gensym = compiler.gensym,

    list = utils.list,
    sym = utils.sym,
    varg = utils.varg,
    path = utils.path,

    loadCode = specials.loadCode,
    macroLoaded = specials.macroLoaded,
    doc = specials.doc,

    eval = eval,
    dofile = compiler.dofileFennel,
    version = "0.5.0-dev",
}

utils.fennelModule = module -- yet another circular dependency =(

-- In order to make this more readable, you can switch your editor to treating
-- this file as if it were Fennel for the purposes of this section
local replsource = [===[(local (fennel internals) ...)

(fn default-read-chunk [parser-state]
  (io.write (if (< 0 parser-state.stackSize) ".." ">> "))
  (io.flush)
  (let [input (io.read)]
    (and input (.. input "\n"))))

(fn default-on-values [xs]
  (io.write (table.concat xs "\t"))
  (io.write "\n"))

(fn default-on-error [errtype err lua-source]
  (io.write
   (match errtype
     "Lua Compile" (.. "Bad code generated - likely a bug with the compiler:\n"
                       "--- Generated Lua Start ---\n"
                       lua-source
                       "--- Generated Lua End ---\n")
     "Runtime" (.. (fennel.traceback err 4) "\n")
     _ (: "%s error: %s\n" :format errtype (tostring err)))))

(local save-source
       (table.concat ["local ___i___ = 1"
                      "while true do"
                      " local name, value = debug.getlocal(1, ___i___)"
                      " if(name and name ~= \"___i___\") then"
                      " ___replLocals___[name] = value"
                      " ___i___ = ___i___ + 1"
                      " else break end end"] "\n"))

(fn splice-save-locals [env lua-source]
  (set env.___replLocals___ (or env.___replLocals___ {}))
  (let [spliced-source []
        bind "local %s = ___replLocals___['%s']"]
    (each [line (lua-source:gmatch "([^\n]+)\n?")]
      (table.insert spliced-source line))
    (each [name (pairs env.___replLocals___)]
      (table.insert spliced-source 1 (bind:format name name)))
    (when (and (< 1 (# spliced-source))
               (: (. spliced-source (# spliced-source)) :match "^ *return .*$"))
      (table.insert spliced-source (# spliced-source) save-source))
    (table.concat spliced-source "\n")))

(fn completer [env scope text]
  (let [matches []
        input-fragment (text:gsub ".*[%s)(]+" "")]
    (fn add-partials [input tbl prefix] ; add partial key matches in tbl
      (each [k (internals.allpairs tbl)]
        (let [k (if (or (= tbl env) (= tbl env.___replLocals___))
                    (. scope.unmanglings k)
                    k)]
          (when (and (< (# matches) 2000) ; stop explosion on too many items
                     (= (type k) "string")
                     (= input (k:sub 0 (# input))))
            (table.insert matches (.. prefix k))))))
    (fn add-matches [input tbl prefix] ; add matches, descending into tbl fields
      (let [prefix (if prefix (.. prefix ".") "")]
        (if (not (input:find "%.")) ; no more dots, so add matches
            (add-partials input tbl prefix)
            (let [(head tail) (input:match "^([^.]+)%.(.*)")
                  raw-head (if (or (= tbl env) (= tbl env.___replLocals___))
                               (. scope.manglings head)
                               head)]
              (when (= (type (. tbl raw-head)) "table")
                (add-matches tail (. tbl raw-head) (.. prefix head)))))))

    (add-matches input-fragment (or scope.specials []))
    (add-matches input-fragment (or scope.macros []))
    (add-matches input-fragment (or env.___replLocals___ []))
    (add-matches input-fragment env)
    (add-matches input-fragment (or env._ENV env._G []))
    matches))

(fn repl [options]
  (let [old-root-options internals.rootOptions
        env (if options.env
                (internals.wrapEnv options.env)
                (setmetatable {} {:__index (or _G._ENV _G)}))
        save-locals? (and (not= options.saveLocals false)
                          env.debug env.debug.getlocal)
        opts {}
        _ (each [k v (pairs options)] (tset opts k v))
        read-chunk (or opts.readChunk default-read-chunk)
        on-values (or opts.onValues default-on-values)
        on-error (or opts.onError default-on-error)
        pp (or opts.pp tostring)
        ;; make parser
        (byte-stream clear-stream) (fennel.granulate read-chunk)
        chars []
        (read reset) (fennel.parser (fn [parser-state]
                                      (let [c (byte-stream parser-state)]
                                        (tset chars (+ (# chars) 1) c)
                                        c)))
        scope (fennel.scope)]

    ;; use metadata unless we've specifically disabled it
    (set opts.useMetadata (not= options.useMetadata false))
    (when (= opts.allowedGlobals nil)
      (set opts.allowedGlobals (internals.currentGlobalNames opts.env)))

    (when opts.registerCompleter
      (opts.registerCompleter (partial completer env scope)))

    (fn loop []
      (each [k (pairs chars)] (tset chars k nil))
      (let [(ok parse-ok? x) (pcall read)
            src-string (string.char ((or _G.unpack table.unpack) chars))]
        (internals.setRootOptions opts)
        (if (not ok)
            (do (on-error "Parse" parse-ok?)
                (clear-stream)
                (reset)
                (loop))
            (when parse-ok? ; if this is false, we got eof
              (match (pcall fennel.compile x {:correlate opts.correlate
                                              :source src-string
                                              :scope scope
                                              :useMetadata opts.useMetadata
                                              :moduleName opts.moduleName
                                              :assert-compile opts.assert-compile
                                              :parse-error opts.parse-error})
                (false msg) (do (clear-stream)
                                (on-error "Compile" msg))
                (true source) (let [source (if save-locals?
                                               (splice-save-locals env source)
                                               source)
                                    (lua-ok? loader) (pcall fennel.loadCode
                                                            source env)]
                                (if (not lua-ok?)
                                    (do (clear-stream)
                                        (on-error "Lua Compile" loader source))
                                    (match (xpcall #[(loader)]
                                                   (partial on-error "Runtime"))
                                      (true ret)
                                      (do (set env._ (. ret 1))
                                          (set env.__ ret)
                                          (on-values (internals.map ret pp)))))))
              (internals.setRootOptions old-root-options)
              (loop)))))
    (loop)))]===]

module.repl = function(options)
    -- functionality the repl needs that isn't part of the public API yet
    local internals = { rootOptions = utils.root.options,
                        setRootOptions = function(r) utils.root.options = r end,
                        currentGlobalNames = specials.currentGlobalNames,
                        wrapEnv = specials.wrapEnv,
                        allpairs = utils.allpairs,
                        map = utils.map }
    return eval(replsource, { correlate = true }, module, internals)(options)
end

module.searchModule = specials.searchModule

module.makeSearcher = function(options)
    return function(modulename)
      -- this will propagate options from the repl but not from eval, because
      -- eval unsets utils.root.options after compiling but before running the actual
      -- calls to require.
      local opts = utils.copy(utils.root.options)
      for k,v in pairs(options or {}) do opts[k] = v end
      local filename = specials.searchModule(modulename)
      if filename then
         return function(modname)
            return compiler.dofileFennel(filename, opts, modname)
         end
      end
   end
end

-- This will allow regular `require` to work with Fennel:
-- table.insert(package.loaders, fennel.searcher)
module.searcher = module.makeSearcher()
module.make_searcher = module.makeSearcher -- oops backwards compatibility

-- Load standard macros
local stdmacros = [===[
{"->" (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."
        (var x val)
        (each [_ e (ipairs [...])]
          (let [elt (if (list? e) e (list e))]
            (table.insert elt 2 x)
            (set x elt)))
        x)
 "->>" (fn [val ...]
         "Thread-last macro.
Same as ->, except splices the value into the last position of each form
rather than the first."
         (var x val)
         (each [_ e (pairs [...])]
           (let [elt (if (list? e) e (list e))]
             (table.insert elt x)
             (set x elt)))
         x)
 "-?>" (fn [val ...]
         "Nil-safe thread-first macro.
Same as -> except will short-circuit with nil when it encounters a nil value."
         (if (= 0 (select "#" ...))
             val
             (let [els [...]
                   e (table.remove els 1)
                   el (if (list? e) e (list e))
                   tmp (gensym)]
               (table.insert el 2 tmp)
               `(let [,tmp ,val]
                  (if ,tmp
                      (-?> ,el ,(unpack els))
                      ,tmp)))))
 "-?>>" (fn [val ...]
         "Nil-safe thread-last macro.
Same as ->> except will short-circuit with nil when it encounters a nil value."
          (if (= 0 (select "#" ...))
              val
              (let [els [...]
                    e (table.remove els 1)
                    el (if (list? e) e (list e))
                    tmp (gensym)]
                (table.insert el tmp)
                `(let [,tmp ,val]
                   (if ,tmp
                       (-?>> ,el ,(unpack els))
                       ,tmp)))))
 :doto (fn [val ...]
         "Evaluates val and splices it into the first argument of subsequent forms."
         (let [name (gensym)
               form `(let [,name ,val])]
           (each [_ elt (pairs [...])]
             (table.insert elt 2 name)
             (table.insert form elt))
           (table.insert form name)
           form))
 :when (fn [condition body1 ...]
         "Evaluate body for side-effects only when condition is truthy."
         (assert body1 "expected body")
         `(if ,condition
              (do ,body1 ,...)))
 :with-open (fn [closable-bindings ...]
              "Like `let`, but invokes (v:close) on every 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."
              (let [bodyfn    `(fn [] ,...)
                    closer    `(fn close-handlers# [ok# ...] (if ok# ... (error ... 0)))
                    traceback `(. (or package.loaded.fennel debug) :traceback)]
                (for [i 1 (# closable-bindings) 2]
                  (assert (sym? (. closable-bindings i))
                    "with-open only allows symbols in bindings")
                  (table.insert closer 4 `(: ,(. closable-bindings i) :close)))
                `(let ,closable-bindings ,closer
                   (close-handlers# (xpcall ,bodyfn ,traceback)))))
 :partial (fn [f ...]
            "Returns a function with all arguments partially applied to f."
            (let [body (list f ...)]
              (table.insert body _VARARG)
              `(fn [,_VARARG] ,body)))
 :pick-args (fn [n f]
               "Creates a function of arity n that applies its arguments to f.
For example,\n\t(pick-args 2 func)
expands to\n\t(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.")
               (let [bindings []]
                 (for [i 1 n] (tset bindings i (gensym)))
                 `(fn ,bindings (,f ,(unpack bindings)))))
 :pick-values (fn [n ...]
                 "Like the `values` special, but emits exactly n values.\nFor example,
\t(pick-values 2 ...)\nexpands to\n\t(let [(_0_ _1_) ...] (values _0_ _1_))"
                 (assert (and (= :number (type n)) (>= n 0) (= n (math.floor n)))
                         "Expected n to be an integer >= 0")
                 (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))))))
 :lambda (fn [...]
           "Function literal with arity checking.
Will throw an exception if a declared argument is passed in as nil, unless
that argument name begins with ?."
           (let [args [...]
                 has-internal-name? (sym? (. args 1))
                 arglist (if has-internal-name? (. args 2) (. args 1))
                 docstring-position (if has-internal-name? 3 2)
                 has-docstring? (and (> (# args) docstring-position)
                                     (= :string (type (. args docstring-position))))
                 arity-check-position (- 4 (if has-internal-name? 0 1) (if has-docstring? 0 1))]
             (fn check! [a]
               (if (table? a)
                   (each [_ a (pairs a)]
                     (check! a))
                   (and (not (: (tostring a) :match "^?"))
                        (not= (tostring a) "&")
                        (not= (tostring a) "..."))
                   (table.insert args arity-check-position
                                 `(assert (not= nil ,a)
                                          (: "Missing argument %s on %s:%s"
                                             :format ,(tostring a)
                                             ,(or a.filename "unknown")
                                             ,(or a.line "?"))))))
             (assert (> (length args) 1) "expected body expression")
             (each [_ a (ipairs arglist)]
               (check! a))
             `(fn ,(unpack args))))
 :macro (fn macro [name ...]
          "Define a single macro."
          (assert (sym? name) "expected symbol for macro name")
          (local args [...])
          `(macros { ,(tostring name) (fn ,name ,(unpack args))}))
 :macrodebug (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)))))
 :import-macros (fn import-macros [binding1 module-name1 ...]
                  "Binds a table of macros from each macro module according to its binding form.
Each binding form can be either a symbol or a k/v destructuring table.
Example:\n  (import-macros mymacros                 :my-macros    ; bind to symbol
                 {:macro1 alias : macro2} :proj.macros) ; import by name"
                  (assert (and binding1 module-name1 (= 0 (% (select :# ...) 2)))
                          "expected even number of binding/modulename pairs")
                  (for [i 1 (select :# binding1 module-name1 ...) 2]
                    (local (binding modname) (select i binding1 module-name1 ...))
                    ;; generate a subscope of current scope, use require-macros to bring in macro
                    ;; module. after that, we just copy the macros from subscope to scope.
                    (local scope (get-scope))
                    (local subscope (fennel.scope scope))
                    (fennel.compileString (string.format "(require-macros %q)" modname)
                                          {:scope subscope})
                    (if (sym? binding)
                      ;; bind whole table of macros to table bound to symbol
                      (do (tset scope.macros (. binding 1) {})
                          (each [k v (pairs subscope.macros)]
                            (tset (. scope.macros (. binding 1)) k v)))

                      ;; 1-level table destructuring for importing individual macros
                      (table? binding)
                      (each [macro-name [import-key] (pairs binding)]
                        (assert (= :function (type (. subscope.macros macro-name)))
                                (.. "macro " macro-name " not found in module " modname))
                        (tset scope.macros import-key (. subscope.macros macro-name)))))
                  ;; TODO: replace with `nil` once we fix macros being able to return nil
                  `(do nil))
 :match
(fn match [val ...]
  "Perform pattern matching on val. See reference for details."
  ;; this function takes the AST of values and a single pattern and returns a
  ;; condition to determine if it matches as well as a list of bindings to
  ;; introduce for the duration of the body if it does match.
  (fn match-pattern [vals pattern unifications]
    ;; we have to assume we're matching against multiple values here until we
    ;; know we're either in a multi-valued clause (in which case we know the #
    ;; of vals) or we're not, in which case we only care about the first one.
    (let [[val] vals]
      (if (or (and (sym? pattern) ; unification with outer locals (or nil)
                   (not= :_ (tostring pattern)) ; never unify _
                   (or (in-scope? pattern)
                       (= :nil (tostring pattern))))
              (and (multi-sym? pattern)
                   (in-scope? (. (multi-sym? pattern) 1))))
          (values `(= ,val ,pattern) [])
          ;; unify a local we've seen already
          (and (sym? pattern)
               (. unifications (tostring pattern)))
          (values `(= ,(. unifications (tostring pattern)) ,val) [])
          ;; bind a fresh local
          (sym? pattern)
          (let [wildcard? (= (tostring pattern) "_")]
            (if (not wildcard?) (tset unifications (tostring pattern) val))
            (values (if (or wildcard? (: (tostring pattern) :find "^?"))
                        true `(not= ,(sym :nil) ,val))
                    [pattern val]))
          ;; guard clause
          (and (list? pattern) (sym? (. pattern 2)) (= :? (tostring (. pattern 2))))
          (let [(pcondition bindings) (match-pattern vals (. pattern 1)
                                                     unifications)
                condition `(and ,pcondition)]
            (for [i 3 (# pattern)] ; splice in guard clauses
              (table.insert condition (. pattern i)))
            (values `(let ,bindings ,condition) bindings))

          ;; multi-valued patterns (represented as lists)
          (list? pattern)
          (let [condition `(and)
                bindings []]
            (each [i pat (ipairs pattern)]
              (let [(subcondition subbindings) (match-pattern [(. vals i)] pat
                                                              unifications)]
                (table.insert condition subcondition)
                (each [_ b (ipairs subbindings)]
                  (table.insert bindings b))))
            (values condition bindings))
          ;; table patterns)
          (= (type pattern) :table)
          (let [condition `(and (= (type ,val) :table))
                bindings []]
            (each [k pat (pairs pattern)]
              (if (and (sym? pat) (= "&" (tostring 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)
                                                           ,val))]))
                  (and (= :number (type k))
                       (= "&" (tostring (. pattern (- k 1)))))
                  nil ; don't process the pattern right after &; already got it
                  (let [subval `(. ,val ,k)
                        (subcondition subbindings) (match-pattern [subval] pat
                                                                  unifications)]
                    (table.insert condition subcondition)
                    (each [_ b (ipairs subbindings)]
                      (table.insert bindings b)))))
            (values condition bindings))
          ;; literal value
          (values `(= ,val ,pattern) []))))
  (fn match-condition [vals clauses]
    (let [out `(if)]
      (for [i 1 (length clauses) 2]
        (let [pattern (. clauses i)
              body (. clauses (+ i 1))
              (condition bindings) (match-pattern vals pattern {})]
          (table.insert out condition)
          (table.insert out `(let ,bindings ,body))))
      out))
  ;; how many multi-valued clauses are there? return a list of that many gensyms
  (fn val-syms [clauses]
    (let [syms (list (gensym))]
      (for [i 1 (length clauses) 2]
        (if (list? (. clauses i))
            (each [valnum (ipairs (. clauses i))]
              (if (not (. syms valnum))
                  (tset syms valnum (gensym))))))
      syms))
  ;; wrap it in a way that prevents double-evaluation of the matched value
  (let [clauses [...]
        vals (val-syms clauses)]
    (if (not= 0 (% (length clauses) 2)) ; treat odd final clause as default
        (table.insert clauses (length clauses) (sym :_)))
    ;; protect against multiple evaluation of the value, bind against as
    ;; many values as we ever match against in the clauses.
    (list (sym :let) [vals val]
          (match-condition vals clauses))))
 }
]===]
do
    -- docstrings rely on having a place to "put" metadata; we use the module
    -- system for that. but if you try to require the module while it's being
    -- loaded, you get a stack overflow. so we fake out the module for the
    -- purposes of boostrapping the built-in macros here.
    local moduleName = "__fennel-bootstrap__"
    package.preload[moduleName] = function() return module end
    local env = specials.makeCompilerEnv(nil, compiler.scopes.compiler, {})
    local macros = eval(stdmacros, {
                            env = env,
                            scope = compiler.makeScope(compiler.scopes.compiler),
                            -- assume the code to load globals doesn't have any
                            -- mistaken globals, otherwise this can be
                            -- problematic when loading fennel in contexts
                            -- where _G is an empty table with an __index
                            -- metamethod. (openresty)
                            allowedGlobals = false,
                            useMetadata = true,
                            filename = "built-ins",
                            moduleName = moduleName })
    for k,v in pairs(macros) do compiler.scopes.global.macros[k] = v end
    package.preload[moduleName] = nil
end
compiler.scopes.global.macros['λ'] = compiler.scopes.global.macros['lambda']

return module

A fennelview.fnl => fennelview.fnl +203 -0
@@ 0,0 1,203 @@
;; A pretty-printer that outputs tables in Fennel syntax.
;; Loosely based on inspect.lua: http://github.com/kikito/inspect.lua

(fn view-quote [str] (.. "\"" (: str :gsub "\"" "\\\"") "\""))

(local short-control-char-escapes
       {"\a" "\\a" "\b" "\\b" "\f" "\\f" "\n" "\\n"
        "\r" "\\r" "\t" "\\t" "\v" "\\v"})

(local long-control-char-escapes
       (let [long {}]
         (for [i 0 31]
           (let [ch (string.char i)]
             (when (not (. short-control-char-escapes ch))
               (tset short-control-char-escapes ch (.. "\\" i))
               (tset long ch (: "\\%03d" :format i)))))
         long))

(fn escape [str]
  (-> str
      (: :gsub "\\" "\\\\")
      (: :gsub "(%c)%f[0-9]" long-control-char-escapes)
      (: :gsub "%c" short-control-char-escapes)))

(fn sequence-key? [k len]
  (and (= (type k) "number")
       (<= 1 k)
       (<= k len)
       (= (math.floor k) k)))

(local type-order {:number 1 :boolean 2 :string 3 :table 4
                   :function 5 :userdata 6 :thread 7})

(fn sort-keys [a b]
  (let [ta (type a) tb (type b)]
    (if (and (= ta tb) (not= ta "boolean")
             (or (= ta "string") (= ta "number")))
        (< a b)
        (let [dta (. type-order a)
              dtb (. type-order b)]
          (if (and dta dtb)
              (< dta dtb)
              dta true
              dtb false
              :else (< ta tb))))))

(fn get-sequence-length [t]
  (var len 1)
  (each [i (ipairs t)] (set len i))
  len)

(fn get-nonsequential-keys [t]
  (let [keys {}
        sequence-length (get-sequence-length t)]
    (each [k (pairs t)]
      (when (not (sequence-key? k sequence-length))
        (table.insert keys k)))
    (table.sort keys sort-keys)
    (values keys sequence-length)))

(fn count-table-appearances [t appearances]
  (if (= (type t) "table")
      (when (not (. appearances t))
        (tset appearances t 1)
        (each [k v (pairs t)]
          (count-table-appearances k appearances)
          (count-table-appearances v appearances)))
      (when (and t (= t t)) ; no nans please
        (tset appearances t (+ (or (. appearances t) 0) 1))))
  appearances)



(var put-value nil) ; mutual recursion going on; defined below

(fn puts [self ...]
  (each [_ v (ipairs [...])]
    (table.insert self.buffer v)))

(fn tabify [self] (puts self "\n" (: self.indent :rep self.level)))

(fn already-visited? [self v] (not= (. self.ids v) nil))

(fn get-id [self v]
  (var id (. self.ids v))
  (when (not id)
    (let [tv (type v)]
      (set id (+ (or (. self.max-ids tv) 0) 1))
      (tset self.max-ids tv id)
      (tset self.ids v id)))
  (tostring id))

(fn put-sequential-table [self t len]
  (puts self "[")
  (set self.level (+ self.level 1))
  (for [i 1 len]
    (when (< 1 i (+ 1 len))
      (puts self " "))
    (put-value self (. t i)))
  (set self.level (- self.level 1))
  (puts self "]"))

(fn put-key [self k]
  (if (and (= (type k) "string")
           (: k :find "^[-%w?\\^_!$%&*+./@:|<=>]+$"))
      (puts self ":" k)
      (put-value self k)))

(fn put-kv-table [self t ordered-keys]
  (puts self "{")
  (set self.level (+ self.level 1))
  ;; first, output sorted nonsequential keys
  (each [i k (ipairs ordered-keys)]
    (when (or self.table-edges (not= i 1))
      (tabify self))
    (put-key self k)
    (puts self " ")
    (put-value self (. t k)))
  ;; next, output any sequential keys
  (each [i v (ipairs t)]
    (tabify self)
    (put-key self i)
    (puts self " ")
    (put-value self v))
  (set self.level (- self.level 1))
  (when self.table-edges
    (tabify self))
  (puts self "}"))

(fn put-table [self t]
  (let [metamethod (and self.metamethod? (-?> t getmetatable (. :__fennelview)))]
    (if (and (already-visited? self t) self.detect-cycles?)
        (puts self "#<table " (get-id self t) ">")
        (>= self.level self.depth)
        (puts self "{...}")
        metamethod
        (puts self (metamethod t self.fennelview))
        :else
        (let [(non-seq-keys len) (get-nonsequential-keys t)
              id (get-id self t)]
          ;; fancy metatable stuff can result in self.appearances not including
          ;; a table, so if it's not found, assume we haven't seen it; we can't
          ;; do cycle detection in that case.
          (if (and (< 1 (or (. self.appearances t) 0)) self.detect-cycles?)
              (puts self "#<table" id ">")
              (and (= (length non-seq-keys) 0) (= (length t) 0))
              (puts self (if self.empty-as-square "[]" "{}"))
              (= (length non-seq-keys) 0)
              (put-sequential-table self t len)
              :else
              (put-kv-table self t non-seq-keys))))))

(set put-value (fn [self v]
                 (let [tv (type v)]
                   (if (= tv "string")
                       (puts self (view-quote (escape v)))
                       (or (= tv "number") (= tv "boolean") (= tv "nil"))
                       (puts self (tostring v))
                       (= tv "table")
                       (put-table self v)
                       :else
                       (puts self "#<" (tostring v) ">")))))



(fn one-line [str]
  ;; save return value as local to ignore gsub's extra return value
  (let [ret (-> str
                (: :gsub "\n" " ")
                (: :gsub "%[ " "[") (: :gsub " %]" "]")
                (: :gsub "%{ " "{") (: :gsub " %}" "}")
                (: :gsub "%( " "(") (: :gsub " %)" ")"))]
    ret))

(fn fennelview [x options]
  "Return a string representation of x.

Can take an options table with these keys:
* :one-line (boolean: default: false) keep the output string as a one-liner
* :depth (number, default: 128) limit how many levels to go (default: 128)
* :indent (string, default: \"  \") use this string to indent each level
* :detect-cycles? (boolean, default: true) don't try to traverse a looping table
* :metamethod? (boolean: default: true) use the __fennelview metamethod if found
* :table-edges (boolean: default: true) put {} table brackets on their own line
* :empty-as-square (boolean: default: true) render empty tables as [], not {}

The __fennelview metamethod should take the table being serialized as its first
argument and a function as its second arg which can be used on table elements to
continue the fennelview process on them.
"
  (let [options (or options {})
        inspector {:appearances (count-table-appearances x {})
                   :depth (or options.depth 128)
                   :level 0 :buffer {} :ids {} :max-ids {}
                   :indent (or options.indent (if options.one-line "" "  "))
                   :detect-cycles? (not (= false options.detect-cycles?))
                   :metamethod? (not (= false options.metamethod?))
                   :fennelview #(fennelview $1 options)
                   :table-edges (not= options.table-edges false)
                   :empty-as-square options.empty-as-square}]
    (put-value inspector x)
    (let [str (table.concat inspector.buffer)]
      (if options.one-line (one-line str) str))))

M fnlfmt => fnlfmt +3624 -17
@@ 1,6 1,6 @@
#!/usr/bin/env lua
local fmt = nil
package.preload["fnlfmt"] = package.preload["fnlfmt"] or function()
package.preload["fnlfmt"] = package.preload["fnlfmt"] or function(...)
  local view = require("fennelview")
  local function identify_line(line, pos, stack)
    local closers = {[")"] = "(", ["\""] = "\"", ["]"] = "[", ["}"] = "{"}
    local char = line:sub(pos, pos)


@@ 88,7 88,7 @@ package.preload["fnlfmt"] = package.preload["fnlfmt"] or function()
      return 0
    end
  end
  local function indent(line, lines, prev_line_num)
  local function indent_line(line, lines, prev_line_num)
    local without_indentation = line:match("[^%s]+.*")
    if without_indentation then
      return ((" "):rep(indentation(lines, prev_line_num)) .. without_indentation)


@@ 96,37 96,3644 @@ package.preload["fnlfmt"] = package.preload["fnlfmt"] or function()
      return ""
    end
  end
  local function fmt(code)
  local function indent(code)
    local lines = {}
    for line in code:gmatch("([^\n]*)\n") do
      table.insert(lines, indent(line, lines, #lines))
      table.insert(lines, indent_line(line, lines, #lines))
    end
    return table.concat(lines, "\n")
  end
  return {fmt = fmt, indentation = indentation}
  local newline = nil
  local function _0_()
    return "\n"
  end
  newline = setmetatable({}, {__fennelview = _0_})
  local function nospace_concat(tbl, sep, start, _end)
    local out = ""
    for i = start, _end do
      local val = tbl[i]
      if ((i == start) or (val == "\n")) then
        out = (out .. val)
      else
        out = (out .. " " .. val)
      end
    end
    return out
  end
  local nil_sym = nil
  local function _1_()
    return "nil"
  end
  nil_sym = setmetatable({}, {__fennelview = _1_})
  local function view_list(self, tostring2)
    local safe, max = {}, 0
    for k in pairs(self) do
      if ((type(k) == "number") and (k > max)) then
        max = k
      end
    end
    do
      local ts = (tostring2 or tostring)
      for i = 1, max, 1 do
        local function _2_()
          if (self[i] == nil) then
            return nil_sym
          else
            return self[i]
          end
        end
        safe[i] = ts(_2_())
      end
    end
    return ("(" .. nospace_concat(safe, " ", 1, max) .. ")")
  end
  local list_mt = {__fennelview = view_list}
  local function walk_tree(root, f, iterator)
    local function walk(iterfn, parent, idx, node)
      if f(idx, node, parent) then
        for k, v in iterfn(node) do
          walk(iterfn, node, k, v)
        end
        return nil
      end
    end
    walk((iterator or pairs), nil, nil, root)
    return root
  end
  local function step_for(_2_0)
    local _3_ = _2_0
    local callee = _3_[1]
    if ({match = true})[tostring(callee)] then
      return -2
    else
      return -1
    end
  end
  local function end_for(node)
    if (tostring(node[1]) == "match") then
      return (#node - 1)
    else
      return #node
    end
  end
  local function start_for(_3_0)
    local _4_ = _3_0
    local callee = _4_[1]
    return ({["do"] = 2, ["for"] = 3, ["if"] = 3, ["while"] = 3, each = 3, fn = 4, let = 3, match = 3, when = 3})[tostring(callee)]
  end
  local function add_newlines(idx, node, parent)
    if ("table" == type(node)) then
      do
        local mt = (getmetatable(node) or {})
        local _4_0 = mt
        if ((type(_4_0) == "table") and (_4_0[1] == "LIST")) then
          setmetatable(node, list_mt)
          if start_for(node) then
            for i = end_for(node), start_for(node), step_for(node) do
              table.insert(node, i, newline)
            end
          end
        elseif ((type(_4_0) == "table") and (nil ~= _4_0.sequence)) then
          local sequence = _4_0.sequence
          if ("let" == tostring(parent[1])) then
            for i = (#node - 1), 2, -2 do
              table.insert(node, i, newline)
            end
          end
        end
      end
      return true
    end
  end
  local function fnlfmt(ast, options)
    return indent((view(walk_tree(ast, add_newlines), {["empty-as-square"] = true, ["table-edges"] = false}) .. "\n\n"))
  end
  return {["indent-line"] = indent_line, fnlfmt = fnlfmt, indent = indent}
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 ~= "boolean") 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
      end
    else
      if (t and (t == t)) then
        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
        return puts(self, "#<table", id, ">")
      elseif ((#non_seq_keys == 0) and (#t == 0)) then
        local function _2_()
          if self["empty-as-square"] then
            return "[]"
          else
            return "{}"
          end
        end
        return puts(self, _2_())
      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))
    elseif (tv == "table") then
      return put_table(self, v)
    elseif "else" then
      return puts(self, "#<", tostring(v), ">")
    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
fmt = require("fnlfmt")
local fennel = nil
package.preload["fennel"] = package.preload["fennel"] or function(...)
local view = nil
  --[[
  Copyright (c) 2016-2019 Calvin Rose and contributors
  Permission is hereby granted, free of charge, to any person obtaining a copy of
  this software and associated documentation files (the "Software"), to deal in
  the Software without restriction, including without limitation the rights to
  use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
  the Software, and to permit persons to whom the Software is furnished to do so,
  subject to the following conditions:
  The above copyright notice and this permission notice shall be included in all
  copies or substantial portions of the Software.
  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
  FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
  COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
  IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
  CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  ]]
  
  -- Make global variables local.
  local setmetatable = setmetatable
  local getmetatable = getmetatable
  local type = type
  local assert = assert
  local pairs = pairs
  local ipairs = ipairs
  local tostring = tostring
  local unpack = unpack or table.unpack
  
  --
  -- Main Types and support functions
  --
  
  local utils = (function()
      -- Like pairs, but gives consistent ordering every time. On 5.1, 5.2, and LuaJIT
      -- pairs is already stable, but on 5.3 every run gives different ordering.
      local function stablepairs(t)
          local keys, succ = {}, {}
          for k in pairs(t) do table.insert(keys, k) end
          table.sort(keys, function(a, b) return tostring(a) < tostring(b) end)
          for i,k in ipairs(keys) do succ[k] = keys[i+1] end
          local function stablenext(tbl, idx)
              if idx == nil then return keys[1], tbl[keys[1]] end
              return succ[idx], tbl[succ[idx]]
          end
          return stablenext, t, nil
      end
  
      -- Map function f over sequential table t, removing values where f returns nil.
      -- Optionally takes a target table to insert the mapped values into.
      local function map(t, f, out)
          out = out or {}
          if type(f) ~= "function" then local s = f f = function(x) return x[s] end end
          for _,x in ipairs(t) do
              local v = f(x)
              if v then table.insert(out, v) end
          end
          return out
      end
  
      -- Map function f over key/value table t, similar to above, but it can return a
      -- sequential table if f returns a single value or a k/v table if f returns two.
      -- Optionally takes a target table to insert the mapped values into.
      local function kvmap(t, f, out)
          out = out or {}
          if type(f) ~= "function" then local s = f f = function(x) return x[s] end end
          for k,x in stablepairs(t) do
              local korv, v = f(k, x)
              if korv and not v then table.insert(out, korv) end
              if korv and v then out[korv] = v end
          end
          return out
      end
  
      -- Returns a shallow copy of its table argument. Returns an empty table on nil.
      local function copy(from)
         local to = {}
         for k, v in pairs(from or {}) do to[k] = v end
         return to
      end
  
      -- Like pairs, but if the table has an __index metamethod, it will recurisvely
      -- traverse upwards, skipping duplicates, to iterate all inherited properties
      local function allpairs(t)
          assert(type(t) == 'table', 'allpairs expects a table')
          local seen = {}
          local function allpairsNext(_, state)
              local nextState, value = next(t, state)
              if seen[nextState] then
                  return allpairsNext(nil, nextState)
              elseif nextState then
                  seen[nextState] = true
                  return nextState, value
              end
              local meta = getmetatable(t)
              if meta and meta.__index then
                  t = meta.__index
                  return allpairsNext(t)
              end
          end
          return allpairsNext
      end
  
      local function deref(self) return self[1] end
  
      local nilSym -- haven't defined sym yet; create this later
  
      local function listToString(self, tostring2)
          local safe, max = {}, 0
          for k in pairs(self) do if type(k) == "number" and k>max then max=k end end
          for i=1,max do -- table.maxn was removed from Lua 5.3 for some reason???
              safe[i] = self[i] == nil and nilSym or self[i]
          end
          return '(' .. table.concat(map(safe, tostring2 or tostring), ' ', 1, max) .. ')'
      end
  
      local SYMBOL_MT = { 'SYMBOL', __tostring = deref, __fennelview = deref }
      local EXPR_MT = { 'EXPR', __tostring = deref }
      local VARARG = setmetatable({ '...' },
          { 'VARARG', __tostring = deref, __fennelview = deref })
      local LIST_MT = { 'LIST', __tostring = listToString, __fennelview = listToString }
      local SEQUENCE_MARKER = { 'SEQUENCE' }
  
      -- Safely load an environment variable
      local getenv = os and os.getenv or function() return nil end
  
      local pathTable = {"./?.fnl", "./?/init.fnl"}
      table.insert(pathTable, getenv("FENNEL_PATH"))
  
      local function debugOn(flag)
          local level = getenv("FENNEL_DEBUG") or ""
          return level == "all" or level:find(flag)
      end
  
      -- Create a new list. Lists are a compile-time construct in Fennel; they are
      -- represented as tables with a special marker metatable. They only come from
      -- the parser, and they represent code which comes from reading a paren form;
      -- they are specifically not cons cells.
      local function list(...)
          return setmetatable({...}, LIST_MT)
      end
  
      -- Create a new symbol. Symbols are a compile-time construct in Fennel and are
      -- not exposed outside the compiler. Symbols have source data describing what
      -- file, line, etc that they came from.
      local function sym(str, scope, source)
          local s = {str, scope = scope}
          for k, v in pairs(source or {}) do
              if type(k) == 'string' then s[k] = v end
          end
          return setmetatable(s, SYMBOL_MT)
      end
  
      nilSym = sym("nil")
  
      -- Create a new sequence. Sequences are tables that come from the parser when
      -- it encounters a form with square brackets. They are treated as regular tables
      -- except when certain macros need to look for binding forms, etc specifically.
      local function sequence(...)
          -- can't use SEQUENCE_MT directly as the sequence metatable like we do with
          -- the other types without giving up the ability to set source metadata
          -- on a sequence, (which we need for error reporting) so embed a marker
          -- value in the metatable instead.
          return setmetatable({...}, {sequence=SEQUENCE_MARKER})
      end
  
      -- Create a new expr
      -- etype should be one of
      --   "literal": literals like numbers, strings, nil, true, false
      --   "expression": Complex strings of Lua code, may have side effects, etc
      --                 but is an expression
      --   "statement": Same as expression, but is also a valid statement
      --                (function calls).
      --   "vargs": varargs symbol
      --   "sym": symbol reference
      local function expr(strcode, etype)
          return setmetatable({ strcode, type = etype }, EXPR_MT)
      end
  
      local function varg()
          return VARARG
      end
  
      local function isExpr(x)
          return type(x) == 'table' and getmetatable(x) == EXPR_MT and x
      end
  
      local function isVarg(x)
          return x == VARARG and x
      end
  
      -- Checks if an object is a List. Returns the object if is a List.
      local function isList(x)
          return type(x) == 'table' and getmetatable(x) == LIST_MT and x
      end
  
      -- Checks if an object is a symbol. Returns the object if it is a symbol.
      local function isSym(x)
          return type(x) == 'table' and getmetatable(x) == SYMBOL_MT and x
      end
  
      -- Checks if an object any kind of table, EXCEPT list or symbol
      local function isTable(x)
          return type(x) == 'table' and
              x ~= VARARG and
              getmetatable(x) ~= LIST_MT and getmetatable(x) ~= SYMBOL_MT and x
      end
  
      -- Checks if an object is a sequence (created with a [] literal)
      local function isSequence(x)
          local mt = type(x) == "table" and getmetatable(x)
          return mt and mt.sequence == SEQUENCE_MARKER and x
      end
  
      -- A multi symbol is a symbol that is actually composed of
      -- two or more symbols using the dot syntax. The main differences
      -- from normal symbols is that they cannot be declared local, and
      -- they may have side effects on invocation (metatables)
      local function isMultiSym(str)
          if isSym(str) then
              return isMultiSym(tostring(str))
          end
          if type(str) ~= 'string' then return end
          local parts = {}
          for part in str:gmatch('[^%.%:]+[%.%:]?') do
              local lastChar = part:sub(-1)
              if lastChar == ":" then
                  parts.multiSymMethodCall = true
              end
              if lastChar == ":" or lastChar == "." then
                  parts[#parts + 1] = part:sub(1, -2)
              else
                  parts[#parts + 1] = part
              end
          end
          return #parts > 0 and
              (str:match('%.') or str:match(':')) and
              (not str:match('%.%.')) and
              str:byte() ~= string.byte '.' and
              str:byte(-1) ~= string.byte '.' and
              parts
      end
  
      local function isQuoted(symbol) return symbol.quoted end
  
      local luaKeywords = {
          'and', 'break', 'do', 'else', 'elseif', 'end', 'false', 'for',
          'function', 'if', 'in', 'local', 'nil', 'not', 'or', 'repeat', 'return',
          'then', 'true', 'until', 'while'
      }
  
      for i, v in ipairs(luaKeywords) do luaKeywords[v] = i end
  
      local function isValidLuaIdentifier(str)
          return (str:match('^[%a_][%w_]*$') and not luaKeywords[str])
      end
  
      -- Certain options should always get propagated onwards when a function that
      -- has options calls down into compile.
      local propagatedOptions = {"allowedGlobals", "indent", "correlate",
                                 "useMetadata", "env"}
      local function propagateOptions(options, subopts)
          for _,name in ipairs(propagatedOptions) do subopts[name] = options[name] end
          return subopts
      end
  
      local root = {
          -- Top level compilation bindings.
          chunk=nil, scope=nil, options=nil,
  
          -- The root.reset function needs to be called at every exit point of the
          -- compiler including when there's a parse error or compiler
          -- error. This would be better done using dynamic scope, but we don't
          -- have dynamic scope, so we fake it by ensuring we call this at every
          -- exit point, including errors.
          reset=function() end,
  
          setReset=function(root)
              local chunk, scope, options = root.chunk, root.scope, root.options
              local oldResetRoot = root.reset -- this needs to nest!
              root.reset = function()
                  root.chunk, root.scope, root.options = chunk, scope, options
                  root.reset = oldResetRoot
              end
          end,
      }
  
      return {
          -- basic general table functions:
          stablepairs=stablepairs, allpairs=allpairs, map=map, kvmap=kvmap,
          copy=copy,
  
          -- AST functions:
          list=list, sym=sym, sequence=sequence, expr=expr, varg=varg,
          isVarg=isVarg, isList=isList, isSym=isSym, isTable=isTable,
          isSequence=isSequence, isMultiSym=isMultiSym, isQuoted=isQuoted,
          isExpr=isExpr, deref=deref,
  
          -- other functions:
          isValidLuaIdentifier=isValidLuaIdentifier, luaKeywords=luaKeywords,
          propagateOptions=propagateOptions, debugOn=debugOn,
          root=root, path=table.concat(pathTable, ";"),}
  end)()
  
  --
  -- Parser
  --
  
  local parser = (function()
      -- Convert a stream of chunks to a stream of bytes.
      -- Also returns a second function to clear the buffer in the byte stream
      local function granulate(getchunk)
          local c = ''
          local index = 1
          local done = false
          return function (parserState)
              if done then return nil end
              if index <= #c then
                  local b = c:byte(index)
                  index = index + 1
                  return b
              else
                  c = getchunk(parserState)
                  if not c or c == '' then
                      done = true
                      return nil
                  end
                  index = 2
                  return c:byte(1)
              end
          end, function ()
              c = ''
          end
      end
  
      -- Convert a string into a stream of bytes
      local function stringStream(str)
          str=str:gsub("^#![^\n]*\n", "") -- remove shebang
          local index = 1
          return function()
              local r = str:byte(index)
              index = index + 1
              return r
          end
      end
  
      -- Table of delimiter bytes - (, ), [, ], {, }
      -- Opener keys have closer as the value, and closers keys
      -- have true as their value.
      local delims = {
          [40] = 41,        -- (
          [41] = true,      -- )
          [91] = 93,        -- [
          [93] = true,      -- ]
          [123] = 125,      -- {
          [125] = true      -- }
      }
  
      local function iswhitespace(b)
          return b == 32 or (b >= 9 and b <= 13)
      end
  
      local function issymbolchar(b)
          return b > 32 and
              not delims[b] and
              b ~= 127 and -- "<BS>"
              b ~= 34 and -- "\""
              b ~= 39 and -- "'"
              b ~= 126 and -- "~"
              b ~= 59 and -- ";"
              b ~= 44 and -- ","
              b ~= 64 and -- "@"
              b ~= 96 -- "`"
      end
  
      local prefixes = { -- prefix chars substituted while reading
          [96] = 'quote', -- `
          [44] = 'unquote', -- ,
          [39] = 'quote', -- '
          [35] = 'hashfn' -- #
      }
  
      -- Parse one value given a function that
      -- returns sequential bytes. Will throw an error as soon
      -- as possible without getting more bytes on bad input. Returns
      -- if a value was read, and then the value read. Will return nil
      -- when input stream is finished.
      local function parser(getbyte, filename, options)
  
          -- Stack of unfinished values
          local stack = {}
  
          -- Provide one character buffer and keep
          -- track of current line and byte index
          local line = 1
          local byteindex = 0
          local lastb
          local function ungetb(ub)
              if ub == 10 then line = line - 1 end
              byteindex = byteindex - 1
              lastb = ub
          end
          local function getb()
              local r
              if lastb then
                  r, lastb = lastb, nil
              else
                  r = getbyte({ stackSize = #stack })
              end
              byteindex = byteindex + 1
              if r == 10 then line = line + 1 end
              return r
          end
  
          -- If you add new calls to this function, please update fenneldfriend.fnl
          -- as well to add suggestions for how to fix the new error.
          local function parseError(msg)
              local source = utils.root.options and utils.root.options.source
              utils.root.reset()
              local override = options and options["parse-error"]
              if override then override(msg, filename or "unknown", line or "?",
                                        byteindex, source) end
              return error(("Parse error in %s:%s: %s"):
                      format(filename or "unknown", line or "?", msg), 0)
          end
  
          -- Parse stream
          return function()
  
              -- Dispatch when we complete a value
              local done, retval
              local whitespaceSinceDispatch = true
              local function dispatch(v)
                  if #stack == 0 then
                      retval = v
                      done = true
                  elseif stack[#stack].prefix then
                      local stacktop = stack[#stack]
                      stack[#stack] = nil
                      return dispatch(utils.list(utils.sym(stacktop.prefix), v))
                  else
                      table.insert(stack[#stack], v)
                  end
                  whitespaceSinceDispatch = false
              end
  
              -- Throw nice error when we expect more characters
              -- but reach end of stream.
              local function badend()
                  local accum = utils.map(stack, "closer")
                  parseError(('expected closing delimiter%s %s'):format(
                      #stack == 1 and "" or "s",
                      string.char(unpack(accum))))
              end
  
              -- The main parse loop
              repeat
                  local b
  
                  -- Skip whitespace
                  repeat
                      b = getb()
                      if b and iswhitespace(b) then
                          whitespaceSinceDispatch = true
                      end
                  until not b or not iswhitespace(b)
                  if not b then
                      if #stack > 0 then badend() end
                      return nil
                  end
  
                  if b == 59 then -- ; Comment
                      repeat
                          b = getb()
                      until not b or b == 10 -- newline
                  elseif type(delims[b]) == 'number' then -- Opening delimiter
                      if not whitespaceSinceDispatch then
                          parseError('expected whitespace before opening delimiter '
                                         .. string.char(b))
                      end
                      table.insert(stack, setmetatable({
                          closer = delims[b],
                          line = line,
                          filename = filename,
                          bytestart = byteindex
                      }, getmetatable(utils.list())))
                  elseif delims[b] then -- Closing delimiter
                      if #stack == 0 then parseError('unexpected closing delimiter '
                                                         .. string.char(b)) end
                      local last = stack[#stack]
                      local val
                      if last.closer ~= b then
                          parseError('mismatched closing delimiter ' .. string.char(b) ..
                                     ', expected ' .. string.char(last.closer))
                      end
                      last.byteend = byteindex -- Set closing byte index
                      if b == 41 then -- ; )
                          val = last
                      elseif b == 93 then -- ; ]
                          val = utils.sequence(unpack(last))
                          -- for table literals we can store file/line/offset source
                          -- data in fields on the table itself, because the AST node
                          -- *is* the table, and the fields would show up in the
                          -- compiled output. keep them on the metatable instead.
                          for k,v in pairs(last) do getmetatable(val)[k]=v end
                      else -- ; }
                          if #last % 2 ~= 0 then
                              byteindex = byteindex - 1
                              parseError('expected even number of values in table literal')
                          end
                          val = {}
                          setmetatable(val, last) -- see note above about source data
                          for i = 1, #last, 2 do
                              if(tostring(last[i]) == ":" and utils.isSym(last[i + 1])
                                 and utils.isSym(last[i])) then
                                  last[i] = tostring(last[i + 1])
                              end
                              val[last[i]] = last[i + 1]
                          end
                      end
                      stack[#stack] = nil
                      dispatch(val)
                  elseif b == 34 then -- Quoted string
                      local state = "base"
                      local chars = {34}
                      stack[#stack + 1] = {closer = 34}
                      repeat
                          b = getb()
                          chars[#chars + 1] = b
                          if state == "base" then
                              if b == 92 then
                                  state = "backslash"
                              elseif b == 34 then
                                  state = "done"
                              end
                          else
                              -- state == "backslash"
                              state = "base"
                          end
                      until not b or (state == "done")
                      if not b then badend() end
                      stack[#stack] = nil
                      local raw = string.char(unpack(chars))
                      local formatted = raw:gsub("[\1-\31]", function (c)
                                                     return '\\' .. c:byte() end)
                      local loadFn = (loadstring or load)(('return %s'):format(formatted))
                      dispatch(loadFn())
                  elseif prefixes[b] then
                      -- expand prefix byte into wrapping form eg. '`a' into '(quote a)'
                      table.insert(stack, {
                          prefix = prefixes[b]
                      })
                      local nextb = getb()
                      if iswhitespace(nextb) then
                          if b == 35 then
                              stack[#stack] = nil
                              dispatch(utils.sym('#'))
                          else
                              parseError('invalid whitespace after quoting prefix')
                          end
                      end
                      ungetb(nextb)
                  elseif issymbolchar(b) or b == string.byte("~") then -- Try sym
                      local chars = {}
                      local bytestart = byteindex
                      repeat
                          chars[#chars + 1] = b
                          b = getb()
                      until not b or not issymbolchar(b)
                      if b then ungetb(b) end
                      local rawstr = string.char(unpack(chars))
                      if rawstr == 'true' then dispatch(true)
                      elseif rawstr == 'false' then dispatch(false)
                      elseif rawstr == '...' then dispatch(utils.varg())
                      elseif rawstr:match('^:.+$') then -- colon style strings
                          dispatch(rawstr:sub(2))
                      elseif rawstr:match("^~") and rawstr ~= "~=" then
                          -- for backwards-compatibility, special-case allowance
                          -- of ~= but all other uses of ~ are disallowed
                          parseError("illegal character: ~")
                      else
                          local forceNumber = rawstr:match('^%d')
                          local numberWithStrippedUnderscores = rawstr:gsub("_", "")
                          local x
                          if forceNumber then
                              x = tonumber(numberWithStrippedUnderscores) or
                                  parseError('could not read number "' .. rawstr .. '"')
                          else
                              x = tonumber(numberWithStrippedUnderscores)
                              if not x then
                                  if(rawstr:match("%.[0-9]")) then
                                      byteindex = (byteindex - #rawstr +
                                                       rawstr:find("%.[0-9]") + 1)
                                      parseError("can't start multisym segment " ..
                                                     "with a digit: ".. rawstr)
                                  elseif(rawstr:match("[%.:][%.:]") and
                                         rawstr ~= "..") then
                                      byteindex = (byteindex - #rawstr +
                                                       rawstr:find("[%.:][%.:]") + 1)
                                      parseError("malformed multisym: " .. rawstr)
                                  elseif(rawstr:match(":.+[%.:]")) then
                                      byteindex = (byteindex - #rawstr +
                                                       rawstr:find(":.+[%.:]"))
                                      parseError("method must be last component "
                                                     .. "of multisym: " .. rawstr)
                                  else
                                      x = utils.sym(rawstr, nil, {line = line,
                                                            filename = filename,
                                                            bytestart = bytestart,
                                                            byteend = byteindex,})
                                  end
                              end
                          end
                          dispatch(x)
                      end
                  else
                      parseError("illegal character: " .. string.char(b))
                  end
              until done
              return true, retval
          end, function ()
              stack = {}
          end
      end
      return { granulate=granulate, stringStream=stringStream, parser=parser }
  end)()
  
  --
  -- Compilation
  --
  
  local compiler = (function()
      local scopes = {}
  
      -- Create a new Scope, optionally under a parent scope. Scopes are compile time
      -- constructs that are responsible for keeping track of local variables, name
      -- mangling, and macros.  They are accessible to user code via the
      -- 'eval-compiler' special form (may change). They use metatables to implement
      -- nesting.
      local function makeScope(parent)
          if not parent then parent = scopes.global end
          return {
              unmanglings = setmetatable({}, {
                  __index = parent and parent.unmanglings
              }),
              manglings = setmetatable({}, {
                  __index = parent and parent.manglings
              }),
              specials = setmetatable({}, {
                  __index = parent and parent.specials
              }),
              macros = setmetatable({}, {
                  __index = parent and parent.macros
              }),
              symmeta = setmetatable({}, {
                  __index = parent and parent.symmeta
              }),
              includes = setmetatable({}, {
                  __index = parent and parent.includes
              }),
              refedglobals = setmetatable({}, {
                  __index = parent and parent.refedglobals
              }),
              autogensyms = {},
              parent = parent,
              vararg = parent and parent.vararg,
              depth = parent and ((parent.depth or 0) + 1) or 0,
              hashfn = parent and parent.hashfn
          }
      end
  
      -- Assert a condition and raise a compile error with line numbers. The ast arg
      -- should be unmodified so that its first element is the form being called.
      -- If you add new calls to this function, please update fenneldfriend.fnl
      -- as well to add suggestions for how to fix the new error.
      local function assertCompile(condition, msg, ast)
          local override = utils.root.options and utils.root.options["assert-compile"]
          if override then
              local source = utils.root.options and utils.root.options.source
              -- don't make custom handlers deal with resetting root; it's error-prone
              if not condition then utils.root.reset() end
              override(condition, msg, ast, source)
              -- should we fall thru to the default check, or should we allow the
              -- override to swallow the error?
          end
          if not condition then
              utils.root.reset()
              local m = getmetatable(ast)
              local filename = m and m.filename or ast.filename or "unknown"
              local line = m and m.line or ast.line or "?"
              -- if we use regular `assert' we can't provide the `level' argument of 0
              error(string.format("Compile error in '%s' %s:%s: %s",
                                  tostring(utils.isSym(ast[1]) and ast[1][1] or
                                               ast[1] or '()'),
                                  filename, line, msg), 0)
          end
          return condition
      end
  
      scopes.global = makeScope()
      scopes.global.vararg = true
      scopes.compiler = makeScope(scopes.global)
      scopes.macro = scopes.global -- used by gensym, in-scope?, etc
  
      -- Allow printing a string to Lua, also keep as 1 line.
      local serializeSubst = {
          ['\a'] = '\\a',
          ['\b'] = '\\b',
          ['\f'] = '\\f',
          ['\n'] = 'n',
          ['\t'] = '\\t',
          ['\v'] = '\\v'
      }
      local function serializeString(str)
          local s = ("%q"):format(str)
          s = s:gsub('.', serializeSubst):gsub("[\128-\255]", function(c)
              return "\\" .. c:byte()
          end)
          return s
      end
  
      -- Mangler for global symbols. Does not protect against collisions,
      -- but makes them unlikely. This is the mangling that is exposed to
      -- to the world.
      local function globalMangling(str)
          if utils.isValidLuaIdentifier(str) then
              return str
          end
          -- Use underscore as escape character
          return '__fnl_global__' .. str:gsub('[^%w]', function (c)
              return ('_%02x'):format(c:byte())
          end)
      end
  
      -- Reverse a global mangling. Takes a Lua identifier and
      -- returns the fennel symbol string that created it.
      local function globalUnmangling(identifier)
          local rest = identifier:match('^__fnl_global__(.*)$')
          if rest then
              local r = rest:gsub('_[%da-f][%da-f]', function (code)
                  return string.char(tonumber(code:sub(2), 16))
              end)
              return r -- don't return multiple values
          else
              return identifier
          end
      end
  
      -- If there's a provided list of allowed globals, don't let references thru that
      -- aren't on the list. This list is set at the compiler entry points of compile
      -- and compileStream.
      local allowedGlobals
  
      local function globalAllowed(name)
          if not allowedGlobals then return true end
          for _, g in ipairs(allowedGlobals) do
              if g == name then return true end
          end
      end
  
      -- Creates a symbol from a string by mangling it.
      -- ensures that the generated symbol is unique
      -- if the input string is unique in the scope.
      local function localMangling(str, scope, ast, tempManglings)
          local append = 0
          local mangling = str
          assertCompile(not utils.isMultiSym(str), 'unexpected multi symbol ' .. str, ast)
  
          -- Mapping mangling to a valid Lua identifier
          if utils.luaKeywords[mangling] or mangling:match('^%d') then
              mangling = '_' .. mangling
          end
          mangling = mangling:gsub('-', '_')
          mangling = mangling:gsub('[^%w_]', function (c)
              return ('_%02x'):format(c:byte())
          end)
  
          -- Prevent name collisions with existing symbols
          local raw = mangling
          while scope.unmanglings[mangling] do
              mangling = raw .. append
              append = append + 1
          end
  
          scope.unmanglings[mangling] = str
          local manglings = tempManglings or scope.manglings
          manglings[str] = mangling
          return mangling
      end
  
      -- Calling this function will mean that further
      -- compilation in scope will use these new manglings
      -- instead of the current manglings.
      local function applyManglings(scope, newManglings, ast)
          for raw, mangled in pairs(newManglings) do
              assertCompile(not scope.refedglobals[mangled],
              "use of global " .. raw .. " is aliased by a local", ast)
              scope.manglings[raw] = mangled
          end
      end
  
      -- Combine parts of a symbol
      local function combineParts(parts, scope)
          local ret = scope.manglings[parts[1]] or globalMangling(parts[1])
          for i = 2, #parts do
              if utils.isValidLuaIdentifier(parts[i]) then
                  if parts.multiSymMethodCall and i == #parts then
                      ret = ret .. ':' .. parts[i]
                  else
                      ret = ret .. '.' .. parts[i]
                  end
              else
                  ret = ret .. '[' .. serializeString(parts[i]) .. ']'
              end
          end
          return ret
      end
  
      -- Generates a unique symbol in the scope.
      local function gensym(scope, base)
          local mangling
          local append = 0
          repeat
              mangling = (base or '') .. '_' .. append .. '_'
              append = append + 1
          until not scope.unmanglings[mangling]
          scope.unmanglings[mangling] = true
          return mangling
      end
  
      -- Generates a unique symbol in the scope based on the base name. Calling
      -- repeatedly with the same base and same scope will return existing symbol
      -- rather than generating new one.
      local function autogensym(base, scope)
          local parts = utils.isMultiSym(base)
          if(parts) then
              parts[1] = autogensym(parts[1], scope)
              return table.concat(parts, parts.multiSymMethodCall and ":" or ".")
          end
  
          if scope.autogensyms[base] then return scope.autogensyms[base] end
          local mangling = gensym(scope, base:sub(1, -2))
          scope.autogensyms[base] = mangling
          return mangling
      end
  
      -- Check if a binding is valid
      local function checkBindingValid(symbol, scope, ast)
          -- Check if symbol will be over shadowed by special
          local name = symbol[1]
          assertCompile(not scope.specials[name] and not scope.macros[name],
                        ("local %s was overshadowed by a special form or macro")
                            :format(name), ast)
          assertCompile(not utils.isQuoted(symbol),
                        ("macro tried to bind %s without gensym"):format(name), symbol)
  
      end
  
      -- Declare a local symbol
      local function declareLocal(symbol, meta, scope, ast, tempManglings)
          checkBindingValid(symbol, scope, ast)
          local name = symbol[1]
          assertCompile(not utils.isMultiSym(name),
                        "unexpected multi symbol " .. name, ast)
          local mangling = localMangling(name, scope, ast, tempManglings)
          scope.symmeta[name] = meta
          return mangling
      end
  
      -- Convert symbol to Lua code. Will only work for local symbols
      -- if they have already been declared via declareLocal
      local function symbolToExpression(symbol, scope, isReference)
          local name = symbol[1]
          local multiSymParts = utils.isMultiSym(name)
          if scope.hashfn then
             if name == '$' then name = '$1' end
             if multiSymParts then
                if multiSymParts[1] == "$" then
                   multiSymParts[1] = "$1"
                   name = table.concat(multiSymParts, ".")
                end
             end
          end
          local parts = multiSymParts or {name}
          local etype = (#parts > 1) and "expression" or "sym"
          local isLocal = scope.manglings[parts[1]]
          if isLocal and scope.symmeta[parts[1]] then scope.symmeta[parts[1]].used = true end
          -- if it's a reference and not a symbol which introduces a new binding
          -- then we need to check for allowed globals
          assertCompile(not isReference or isLocal or globalAllowed(parts[1]),
                        'unknown global in strict mode: ' .. parts[1], symbol)
          if not isLocal then
              utils.root.scope.refedglobals[parts[1]] = true
          end
          return utils.expr(combineParts(parts, scope), etype)
      end
  
  
      -- Emit Lua code
      local function emit(chunk, out, ast)
          if type(out) == 'table' then
              table.insert(chunk, out)
          else
              table.insert(chunk, {leaf = out, ast = ast})
          end
      end
  
      -- Do some peephole optimization.
      local function peephole(chunk)
          if chunk.leaf then return chunk end
          -- Optimize do ... end in some cases.
          if #chunk >= 3 and
              chunk[#chunk - 2].leaf == 'do' and
              not chunk[#chunk - 1].leaf and
              chunk[#chunk].leaf == 'end' then
              local kid = peephole(chunk[#chunk - 1])
              local newChunk = {ast = chunk.ast}
              for i = 1, #chunk - 3 do table.insert(newChunk, peephole(chunk[i])) end
              for i = 1, #kid do table.insert(newChunk, kid[i]) end
              return newChunk
          end
          -- Recurse
          return utils.map(chunk, peephole)
      end
  
      -- correlate line numbers in input with line numbers in output
      local function flattenChunkCorrelated(mainChunk)
          local function flatten(chunk, out, lastLine, file)
              if chunk.leaf then
                  out[lastLine] = (out[lastLine] or "") .. " " .. chunk.leaf
              else
                  for _, subchunk in ipairs(chunk) do
                      -- Ignore empty chunks
                      if subchunk.leaf or #subchunk > 0 then
                          -- don't increase line unless it's from the same file
                          if subchunk.ast and file == subchunk.ast.file then
                              lastLine = math.max(lastLine, subchunk.ast.line or 0)
                          end
                          lastLine = flatten(subchunk, out, lastLine, file)
                      end
                  end
              end
              return lastLine
          end
          local out = {}
          local last = flatten(mainChunk, out, 1, mainChunk.file)
          for i = 1, last do
              if out[i] == nil then out[i] = "" end
          end
          return table.concat(out, "\n")
      end
  
      -- Flatten a tree of indented Lua source code lines.
      -- Tab is what is used to indent a block.
      local function flattenChunk(sm, chunk, tab, depth)
          if type(tab) == 'boolean' then tab = tab and '  ' or '' end
          if chunk.leaf then
              local code = chunk.leaf
              local info = chunk.ast
              -- Just do line info for now to save memory
              if sm then sm[#sm + 1] = info and info.line or -1 end
              return code
          else
              local parts = utils.map(chunk, function(c)
                  if c.leaf or #c > 0 then -- Ignore empty chunks
                      local sub = flattenChunk(sm, c, tab, depth + 1)
                      if depth > 0 then sub = tab .. sub:gsub('\n', '\n' .. tab) end
                      return sub
                  end
              end)
              return table.concat(parts, '\n')
          end
      end
  
      -- Some global state for all fennel sourcemaps. For the time being,
      -- this seems the easiest way to store the source maps.
      -- Sourcemaps are stored with source being mapped as the key, prepended
      -- with '@' if it is a filename (like debug.getinfo returns for source).
      -- The value is an array of mappings for each line.
      local fennelSourcemap = {}
      -- TODO: loading, unloading, and saving sourcemaps?
  
      local function makeShortSrc(source)
          source = source:gsub('\n', ' ')
          if #source <= 49 then
              return '[fennel "' .. source .. '"]'
          else
              return '[fennel "' .. source:sub(1, 46) .. '..."]'
          end
      end
  
      -- Return Lua source and source map table
      local function flatten(chunk, options)
          chunk = peephole(chunk)
          if(options.correlate) then
              return flattenChunkCorrelated(chunk), {}
          else
              local sm = {}
              local ret = flattenChunk(sm, chunk, options.indent, 0)
              if sm then
                  local key, short_src
                  if options.filename then
                      short_src = options.filename
                      key = '@' .. short_src
                  else
                      key = ret
                      short_src = makeShortSrc(options.source or ret)
                  end
                  sm.short_src = short_src
                  sm.key = key
                  fennelSourcemap[key] = sm
              end
              return ret, sm
          end
      end
  
      -- module-wide state for metadata
      -- create metadata table with weakly-referenced keys
      local function makeMetadata()
          return setmetatable({}, {
              __mode = 'k',
              __index = {
                  get = function(self, tgt, key)
                      if self[tgt] then return self[tgt][key] end
                  end,
                  set = function(self, tgt, key, value)
                      self[tgt] = self[tgt] or {}
                      self[tgt][key] = value
                      return tgt
                  end,
                  setall = function(self, tgt, ...)
                      local kvLen, kvs = select('#', ...), {...}
                      if kvLen % 2 ~= 0 then
                          error('metadata:setall() expected even number of k/v pairs')
                      end
                      self[tgt] = self[tgt] or {}