34fcfc4485d1d5a249415f2c0f58bbfd9febaac2 — Phil Hagelberg 1 year, 15 days ago
Initial commit.
6 files changed, 2725 insertions(+), 0 deletions(-)

A LICENSE
A bencode.lua
A fennel
A fennel.lua
A readme.md
A shevek.fnl
A  => LICENSE +165 -0
@@ 1,165 @@
+                   GNU LESSER GENERAL PUBLIC LICENSE
+                       Version 3, 29 June 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+
+  This version of the GNU Lesser General Public License incorporates
+the terms and conditions of version 3 of the GNU General Public
+License, supplemented by the additional permissions listed below.
+
+  0. Additional Definitions.
+
+  As used herein, "this License" refers to version 3 of the GNU Lesser
+General Public License, and the "GNU GPL" refers to version 3 of the GNU
+General Public License.
+
+  "The Library" refers to a covered work governed by this License,
+other than an Application or a Combined Work as defined below.
+
+  An "Application" is any work that makes use of an interface provided
+by the Library, but which is not otherwise based on the Library.
+Defining a subclass of a class defined by the Library is deemed a mode
+of using an interface provided by the Library.
+
+  A "Combined Work" is a work produced by combining or linking an
+Application with the Library.  The particular version of the Library
+with which the Combined Work was made is also called the "Linked
+Version".
+
+  The "Minimal Corresponding Source" for a Combined Work means the
+Corresponding Source for the Combined Work, excluding any source code
+for portions of the Combined Work that, considered in isolation, are
+based on the Application, and not on the Linked Version.
+
+  The "Corresponding Application Code" for a Combined Work means the
+object code and/or source code for the Application, including any data
+and utility programs needed for reproducing the Combined Work from the
+Application, but excluding the System Libraries of the Combined Work.
+
+  1. Exception to Section 3 of the GNU GPL.
+
+  You may convey a covered work under sections 3 and 4 of this License
+without being bound by section 3 of the GNU GPL.
+
+  2. Conveying Modified Versions.
+
+  If you modify a copy of the Library, and, in your modifications, a
+facility refers to a function or data to be supplied by an Application
+that uses the facility (other than as an argument passed when the
+facility is invoked), then you may convey a copy of the modified
+version:
+
+   a) under this License, provided that you make a good faith effort to
+   ensure that, in the event an Application does not supply the
+   function or data, the facility still operates, and performs
+   whatever part of its purpose remains meaningful, or
+
+   b) under the GNU GPL, with none of the additional permissions of
+   this License applicable to that copy.
+
+  3. Object Code Incorporating Material from Library Header Files.
+
+  The object code form of an Application may incorporate material from
+a header file that is part of the Library.  You may convey such object
+code under terms of your choice, provided that, if the incorporated
+material is not limited to numerical parameters, data structure
+layouts and accessors, or small macros, inline functions and templates
+(ten or fewer lines in length), you do both of the following:
+
+   a) Give prominent notice with each copy of the object code that the
+   Library is used in it and that the Library and its use are
+   covered by this License.
+
+   b) Accompany the object code with a copy of the GNU GPL and this license
+   document.
+
+  4. Combined Works.
+
+  You may convey a Combined Work under terms of your choice that,
+taken together, effectively do not restrict modification of the
+portions of the Library contained in the Combined Work and reverse
+engineering for debugging such modifications, if you also do each of
+the following:
+
+   a) Give prominent notice with each copy of the Combined Work that
+   the Library is used in it and that the Library and its use are
+   covered by this License.
+
+   b) Accompany the Combined Work with a copy of the GNU GPL and this license
+   document.
+
+   c) For a Combined Work that displays copyright notices during
+   execution, include the copyright notice for the Library among
+   these notices, as well as a reference directing the user to the
+   copies of the GNU GPL and this license document.
+
+   d) Do one of the following:
+
+       0) Convey the Minimal Corresponding Source under the terms of this
+       License, and the Corresponding Application Code in a form
+       suitable for, and under terms that permit, the user to
+       recombine or relink the Application with a modified version of
+       the Linked Version to produce a modified Combined Work, in the
+       manner specified by section 6 of the GNU GPL for conveying
+       Corresponding Source.
+
+       1) Use a suitable shared library mechanism for linking with the
+       Library.  A suitable mechanism is one that (a) uses at run time
+       a copy of the Library already present on the user's computer
+       system, and (b) will operate properly with a modified version
+       of the Library that is interface-compatible with the Linked
+       Version.
+
+   e) Provide Installation Information, but only if you would otherwise
+   be required to provide such information under section 6 of the
+   GNU GPL, and only to the extent that such information is
+   necessary to install and execute a modified version of the
+   Combined Work produced by recombining or relinking the
+   Application with a modified version of the Linked Version. (If
+   you use option 4d0, the Installation Information must accompany
+   the Minimal Corresponding Source and Corresponding Application
+   Code. If you use option 4d1, you must provide the Installation
+   Information in the manner specified by section 6 of the GNU GPL
+   for conveying Corresponding Source.)
+
+  5. Combined Libraries.
+
+  You may place library facilities that are a work based on the
+Library side by side in a single library together with other library
+facilities that are not Applications and are not covered by this
+License, and convey such a combined library under terms of your
+choice, if you do both of the following:
+
+   a) Accompany the combined library with a copy of the same work based
+   on the Library, uncombined with any other library facilities,
+   conveyed under the terms of this License.
+
+   b) Give prominent notice with the combined library that part of it
+   is a work based on the Library, and explaining where to find the
+   accompanying uncombined form of the same work.
+
+  6. Revised Versions of the GNU Lesser General Public License.
+
+  The Free Software Foundation may publish revised and/or new versions
+of the GNU Lesser General Public License from time to time. Such new
+versions will be similar in spirit to the present version, but may
+differ in detail to address new problems or concerns.
+
+  Each version is given a distinguishing version number. If the
+Library as you received it specifies that a certain numbered version
+of the GNU Lesser General Public License "or any later version"
+applies to it, you have the option of following the terms and
+conditions either of that published version or of any later version
+published by the Free Software Foundation. If the Library as you
+received it does not specify a version number of the GNU Lesser
+General Public License, you may choose any version of the GNU Lesser
+General Public License ever published by the Free Software Foundation.
+
+  If the Library as you received it specifies that a proxy can decide
+whether future versions of the GNU Lesser General Public License shall
+apply, that proxy's public statement of acceptance of any version is
+permanent authorization for you to choose that version for the
+Library.

A  => bencode.lua +97 -0
@@ 1,97 @@
+-- needed for nrepl client
+local encode, decode
+
+local function decode_list(str, t, total_len)
+   -- print("  list", str, lume.serialize(t))
+   if(str:sub(1,1) == "e") then return t, total_len + 1 end
+   local value, v_len = decode(str)
+   if(not value) then return value, v_len end
+   table.insert(t, value)
+   total_len = total_len + v_len
+   return decode_list(str:sub(v_len + 1), t, total_len)
+end
+
+local function decode_table(str, t, total_len)
+   -- print("  table", str, lume.serialize(t))
+   if(str:sub(1,1) == "e") then return t, total_len + 1 end
+   local key, k_len = decode(str)
+   if(not key) then return key, k_len end
+   local value, v_len = decode(str:sub(k_len+1))
+   if(not value) then return value, v_len end
+   local end_pos = 1 + k_len + v_len
+   t[key] = value
+   total_len = total_len + k_len + v_len
+   return decode_table(str:sub(end_pos), t, total_len)
+end
+
+function decode(str)
+   -- print("decoding", str)
+   if(str:sub(1,1) == "l") then
+      return decode_list(str:sub(2), {}, 1)
+   elseif(str:sub(1,1) == "d") then
+      return decode_table(str:sub(2), {}, 1)
+   elseif(str:sub(1,1) == "i") then
+      -- print("  number", tonumber(str:sub(2, str:find("e") - 1)))
+      return(tonumber(str:sub(2, str:find("e") - 1))), str:find("e")
+   elseif(str:match("[0-9]+")) then
+      local num_str = str:match("[0-9]+")
+      local beginning_of_string = #num_str + 2
+      local str_len = tonumber(num_str)
+      local total_len = beginning_of_string + str_len - 1
+      -- print("  string", str:sub(beginning_of_string))
+      return str:sub(beginning_of_string, total_len), total_len
+   else
+      return false, "Could not parse "..str
+   end
+end
+
+local function decode_all(str, already)
+   local decoded, len_or_err = decode(str)
+   if(not decoded) then return decoded, len_or_err, already end
+   already = already or {}
+   table.insert(already, decoded)
+   if(decoded and #str == len_or_err) then
+      return already
+   elseif(decoded) then
+      return decode_all(str:sub(len_or_err + 1), already)
+   else
+      return false, len_or_err
+   end
+end
+
+local function encode_str(s) return #s .. ":" .. s end
+local function encode_int(n) return "i" .. tostring(n) .. "e" end
+
+local function encode_table(t)
+   local s = "d"
+   for k,v in pairs(t) do s = s .. encode(k) .. encode(v) end
+   return s .. "e"
+end
+
+local function encode_list(l)
+   local s = "l"
+   for _,x in ipairs(l) do s = s .. encode(x) end
+   return s .. "e"
+end
+
+local function count(tbl)
+   local i = 0
+   for _ in pairs(tbl) do i = i + 1 end
+   return i
+end
+
+function encode(x)
+   if(type(x) == "table" and select("#", unpack(x)) == count(x)) then
+      return encode_list(x)
+   elseif(type(x) == "table") then
+      return encode_table(x)
+   elseif(type(x) == "number" and math.floor(x) == x) then
+      return encode_int(x)
+   elseif(type(x) == "string") then
+      return encode_str(x)
+   else
+      return false, "Could not encode " .. type(x) .. ": " .. tostring(x)
+   end
+end
+
+return {decode=decode, decode_all=decode_all, encode=encode}

A  => fennel +133 -0
@@ 1,133 @@
+#!/usr/bin/env lua
+
+local fennel_dir = arg[0]:match("(.-)[^\\/]+$")
+package.path = fennel_dir .. "?.lua;" .. package.path
+local fennel = require('fennel')
+local unpack = unpack or table.unpack
+
+local help = [[
+Usage: fennel [FLAG] [FILE]
+
+Run fennel, a lisp programming language for the Lua runtime.
+
+  --repl                  : Launch an interactive repl session
+  --compile FILES         : Compile files and write their Lua to stdout
+
+  --no-searcher           : Skip installing package.searchers entry
+  --indent VAL            : Indent compiler output with VAL
+  --add-package-path PATH : Add PATH to package.path for finding Lua modules
+  --add-fennel-path  PATH : Add PATH to fennel.path for finding Fennel modules
+
+  --help                  : Display this text
+  --version               : Show version
+
+  When not given a flag, runs the file given as the first argument.
+  When given neither flag nor file, launches a repl.
+
+  If ~/.fennelrc exists, loads it before launching a repl.]]
+
+local options = {
+    sourcemap = true
+}
+
+local function dosafe(filename, opts, args)
+    local ok, val = xpcall(function()
+        return fennel.dofile(filename, opts, unpack(args))
+    end, fennel.traceback)
+    if not ok then
+        io.stderr:write(val .. "\n")
+        os.exit(1)
+    end
+    return val
+end
+
+for i=#arg, 1, -1 do
+    if arg[i] == "--no-searcher" then
+        options.no_searcher = true
+        table.remove(arg, i)
+    elseif arg[i] == "--indent" then
+        options.indent = table.remove(arg, i+1)
+        if options.indent == "false" then options.indent = false end
+        table.remove(arg, i)
+    elseif arg[i] == "--add-package-path" then
+        local entry = table.remove(arg, i+1)
+        package.path = entry .. ";" .. package.path
+        table.remove(arg, i)
+    elseif arg[i] == "--add-fennel-path" then
+        local entry = table.remove(arg, i+1)
+        fennel.path = entry .. ";" .. fennel.path
+        table.remove(arg, i)
+    elseif arg[i] == "--sourcemap" then
+        options.sourcemap = table.remove(arg, i+1)
+        if options.sourcemap == "false" then options.sourcemap = false end
+        table.remove(arg, i)
+    end
+end
+
+if not options.no_searcher then
+    table.insert((package.loaders or package.searchers),
+        fennel.make_searcher({correlate = true}))
+end
+
+-- Try to load readline library
+local function tryReadline(opts)
+    local ok, readline = pcall(require, "readline")
+    if ok then
+        readline.set_options({
+            keeplines = 1000
+        })
+        function opts.readChunk(parserState)
+            local prompt = parserState.stackSize > 0 and '.. ' or '>> '
+            local str = readline.readline(prompt)
+            if str then
+                return str .. "\n"
+            end
+        end
+    end
+end
+
+if arg[1] == "--repl" or #arg == 0 then
+    local ppok, pp = pcall(fennel.dofile, fennel_dir .. "fennelview.fnl", options)
+    if ppok then
+        options.pp = pp
+    else
+        ppok, pp = pcall(require, "fennelview")
+        if ppok then
+            options.pp = pp
+        end
+    end
+    local initFilename = (os.getenv("HOME") or "") .. "/.fennelrc"
+    local init = io.open(initFilename, "rb")
+
+    tryReadline(options)
+
+    if init then
+        init:close()
+        -- pass in options so fennerlrc can make changes to it
+        dosafe(initFilename, options, options)
+    end
+    print("Welcome to fennel!")
+    fennel.repl(options)
+elseif arg[1] == "--compile" then
+    for i = 2, #arg do
+        local f = arg[i] == "-" and io.stdin or assert(io.open(arg[i], "rb"))
+        options.filename=arg[i]
+        local ok, val = xpcall(function()
+            return fennel.compileString(f:read("*all"), options)
+        end, fennel.traceback)
+        if ok then
+            print(val)
+        else
+            io.stderr:write(val .. "\n")
+            os.exit(1)
+        end
+        f:close()
+    end
+elseif arg[1] == "--version" or arg[1] == "-v" then
+    print("Fennel " .. fennel.version)
+elseif #arg >= 1 and arg[1] ~= "--help" then
+    local filename = table.remove(arg, 1) -- let the script have remaining args
+    dosafe(filename, nil, arg)
+else
+    print(help)
+end

A  => fennel.lua +2229 -0
@@ 1,2229 @@
+--[[
+Copyright (c) 2016-2018 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 function deref(self) return self[1] end
+
+local SYMBOL_MT = { 'SYMBOL', __tostring = deref }
+local EXPR_MT = { 'EXPR', __tostring = deref }
+local VARARG = setmetatable({ '...' }, { 'VARARG', __tostring = deref })
+local LIST_MT = { 'LIST',
+    __tostring = function (self)
+        local strs = {}
+        for _, s in ipairs(self) do
+            table.insert(strs, tostring(s))
+        end
+        return '(' .. table.concat(strs, ', ', 1, #self) .. ')'
+    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
+
+-- Create a new list
+local function list(...)
+    return setmetatable({...}, LIST_MT)
+end
+
+-- Create a new symbol
+local function sym(str, scope, meta)
+    local s = {str, scope = scope}
+    if meta then
+        for k, v in pairs(meta) do
+            if type(k) == 'string' then s[k] = v end
+        end
+    end
+    return setmetatable(s, SYMBOL_MT)
+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 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
+
+--
+-- Parser
+--
+
+-- 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)
+    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) or b == 44
+end
+
+local function issymbolchar(b)
+    return b > 32 and
+        not delims[b] and
+        b ~= 127 and -- "<BS>"
+        b ~= 34 and -- "\""
+        b ~= 39 and -- "'"
+        b ~= 59 and -- ";"
+        b ~= 44 and -- ","
+        b ~= 96 -- "`"
+end
+
+local prefixes = { -- prefix chars substituted while reading
+    [96] = 'quote', -- `
+    [64] = 'unquote' -- @
+}
+
+-- 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)
+
+    -- 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
+    local function parseError(msg)
+        return error(msg .. ' in ' .. (filename or 'unknown') .. ':' .. line, 0)
+    end
+
+    -- Parse stream
+    return function()
+
+        -- Dispatch when we complete a value
+        local done, retval
+        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(list(sym(stacktop.prefix), v))
+            else
+                table.insert(stack[#stack], v)
+            end
+        end
+
+        -- The main parse loop
+        repeat
+            local b
+
+            -- Skip whitespace
+            repeat
+                b = getb()
+            until not b or not iswhitespace(b)
+            if not b then
+                if #stack > 0 then parseError 'unexpected end of source' 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
+                table.insert(stack, setmetatable({
+                    closer = delims[b],
+                    line = line,
+                    filename = filename,
+                    bytestart = byteindex
+                }, LIST_MT))
+            elseif delims[b] then -- Closing delimiter
+                if #stack == 0 then parseError 'unexpected closing delimiter' end
+                local last = stack[#stack]
+                local val
+                if last.closer ~= b then
+                    parseError('unexpected 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 = {}
+                    for i = 1, #last do
+                        val[i] = last[i]
+                    end
+                else -- }
+                    if #last % 2 ~= 0 then
+                        parseError('expected even number of values in table literal')
+                    end
+                    val = {}
+                    for i = 1, #last, 2 do
+                        val[last[i]] = last[i + 1]
+                    end
+                end
+                stack[#stack] = nil
+                dispatch(val)
+            elseif b == 34 or b == 39 then -- Quoted string
+                local start = b
+                local state = "base"
+                local chars = {start}
+                repeat
+                    b = getb()
+                    chars[#chars + 1] = b
+                    if state == "base" then
+                        if b == 92 then
+                            state = "backslash"
+                        elseif b == start then
+                            state = "done"
+                        end
+                    else
+                        -- state == "backslash"
+                        state = "base"
+                    end
+                until not b or (state == "done")
+                if not b then parseError('unexpected end of source') end
+                local raw = string.char(unpack(chars))
+                local formatted = raw:gsub("[\1-\31]", function (c) return '\\' .. c:byte() end)
+                local loadFn = loadCode(('return %s'):format(formatted), nil, filename)
+                dispatch(loadFn())
+            elseif prefixes[b] then -- expand prefix byte into wrapping form eg. '`a' into '(quote a)'
+                table.insert(stack, {
+                    prefix = prefixes[b]
+                })
+            else -- Try symbol
+                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(VARARG)
+                elseif rawstr:match('^:.+$') then -- keyword style strings
+                    dispatch(rawstr:sub(2))
+                else
+                    local forceNumber = rawstr:match('^%d')
+                    local numberWithStrippedUnderscores = rawstr:gsub("_", "")
+                    local x
+                    if forceNumber then
+                        x = tonumber(numberWithStrippedUnderscores) or
+                            parseError('could not read token "' .. rawstr .. '"')
+                    else
+                        x = tonumber(numberWithStrippedUnderscores) or
+                            sym(rawstr, nil, { line = line,
+                                               filename = filename,
+                                               bytestart = bytestart,
+                                               byteend = byteindex, })
+                    end
+                    dispatch(x)
+                end
+            end
+        until done
+        return true, retval
+    end, function ()
+        stack = {}
+    end
+end
+
+--
+-- Compilation
+--
+
+-- 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 '*compiler' special form (may change). They
+-- use metatables to implement nesting via inheritance.
+local function makeScope(parent)
+    return {
+        unmanglings = setmetatable({}, {
+            __index = parent and parent.unmanglings
+        }),
+        manglings = setmetatable({}, {
+            __index = parent and parent.manglings
+        }),
+        specials = setmetatable({}, {
+            __index = parent and parent.specials
+        }),
+        symmeta = setmetatable({}, {
+            __index = parent and parent.symmeta
+        }),
+        parent = parent,
+        vararg = parent and parent.vararg,
+        depth = parent and ((parent.depth or 0) + 1) or 0
+    }
+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.
+local function assertCompile(condition, msg, ast)
+    -- if we use regular `assert' we can't provide the `level' argument of zero
+    if not condition then
+        error(string.format("Compile error in '%s' %s:%s: %s",
+                            isSym(ast[1]) and ast[1][1] or ast[1] or '()',
+                            ast.filename or "unknown", ast.line or '?', msg), 0)
+    end
+    return condition
+end
+
+local GLOBAL_SCOPE = makeScope()
+GLOBAL_SCOPE.vararg = true
+local SPECIALS = GLOBAL_SCOPE.specials
+local COMPILER_SCOPE = makeScope(GLOBAL_SCOPE)
+
+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
+
+-- 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
+
+-- 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 type(str) ~= 'string' then return end
+    local parts = {}
+    for part in str:gmatch('[^%.]+') do
+        parts[#parts + 1] = part
+    end
+    return #parts > 0 and
+    str:match('%.') and
+    (not str:match('%.%.')) and
+    str:byte() ~= string.byte '.' and
+    str:byte(-1) ~= string.byte '.' and
+    parts
+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 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
+        return rest:gsub('_[%da-f][%da-f]', function (code)
+            return string.char(tonumber(code:sub(2), 16))
+        end)
+    else
+        return identifier
+    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)
+    if scope.manglings[str] then
+        return scope.manglings[str]
+    end
+    local append = 0
+    local mangling = str
+    assertCompile(not isMultiSym(str), 'did not expect multi symbol ' .. str, ast)
+
+    -- Mapping mangling to a valid Lua identifier
+    if 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)
+
+    local raw = mangling
+    while scope.unmanglings[mangling] do
+        mangling = raw .. append
+        append = append + 1
+    end
+    scope.unmanglings[mangling] = str
+    scope.manglings[str] = mangling
+    return mangling
+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 isValidLuaIdentifier(parts[i]) then
+            ret = ret .. '.' .. parts[i]
+        else
+            ret = ret .. '[' .. serializeString(parts[i]) .. ']'
+        end
+    end
+    return ret
+end
+
+-- Generates a unique symbol in the scope.
+local function gensym(scope)
+    local mangling
+    local append = 0
+    repeat
+        mangling = '_' .. append .. '_'
+        append = append + 1
+    until not scope.unmanglings[mangling]
+    scope.unmanglings[mangling] = true
+    return mangling
+end
+
+-- Declare a local symbol
+local function declareLocal(symbol, meta, scope, ast)
+    local name = symbol[1]
+    assertCompile(not isMultiSym(name), "did not expect mutltisym", ast)
+    local mangling = localMangling(name, scope, ast)
+    scope.symmeta[name] = meta
+    return mangling
+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
+
+-- 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 parts = isMultiSym(name) or {name}
+    local etype = (#parts > 1) and "expression" or "sym"
+    local isLocal = scope.manglings[parts[1]]
+    -- 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)
+    return 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[1].leaf == 'do' and
+        not chunk[2].leaf and
+        chunk[3].leaf == 'end' then
+        return peephole(chunk[2])
+    end
+    -- Recurse
+    for i, v in ipairs(chunk) do
+        chunk[i] = peephole(v)
+    end
+    return chunk
+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 = {}
+        for i = 1, #chunk do
+            -- Ignore empty chunks
+            if chunk[i].leaf or #(chunk[i]) > 0 then
+                local sub = flattenChunk(sm, chunk[i], tab, depth + 1)
+                if depth > 0 then sub = tab .. sub:gsub('\n', '\n' .. tab) end
+                table.insert(parts, 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)
+    local sm = options.sourcemap and {}
+    chunk = peephole(chunk)
+    if(options.correlate) then
+        return flattenChunkCorrelated(chunk), {}
+    else
+        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
+
+-- Convert expressions to Lua string
+local function exprs1(exprs)
+    local t = {}
+    for _, e in ipairs(exprs) do
+        t[#t + 1] = e[1]
+    end
+    return table.concat(t, ', ')
+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
+            emit(chunk, tostring(se), 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, len do
+                    exprs[i] = nil
+                end
+            else
+                -- Pad with nils
+                for i = #exprs + 1, n do
+                    exprs[i] = expr('nil', 'literal')
+                end
+            end
+        end
+    end
+    if opts.tail then
+        emit(parent, ('return %s'):format(exprs1(exprs)), ast)
+    end
+    if opts.target then
+        emit(parent, ('%s = %s'):format(opts.target, exprs1(exprs)), 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
+
+-- 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.
+local function compile1(ast, scope, parent, opts)
+    opts = opts or {}
+    local exprs = {}
+
+    -- Compile the form
+    if isList(ast) then
+        -- Function call or special form
+        local len = #ast
+        assertCompile(len > 0, "expected a function to call", ast)
+        -- Test for special form
+        local first = ast[1]
+        if isSym(first) then -- Resolve symbol
+            first = first[1]
+        end
+        local special = scope.specials[first]
+        if special and isSym(ast[1]) then
+            -- Special form
+            exprs = special(ast, scope, parent, opts) or expr('nil', 'literal')
+            -- Be very accepting of strings or expression
+            -- as well as lists or expressions
+            if type(exprs) == 'string' then exprs = expr(exprs, 'expression') end
+            if getmetatable(exprs) == EXPR_MT 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
+        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 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({expr(call, 'statement')}, parent, opts, ast)
+        end
+    elseif isVarg(ast) then
+        assertCompile(scope.vararg, "unexpected vararg", ast)
+        exprs = handleCompileOpts({expr('...', 'varg')}, parent, opts, ast)
+    elseif isSym(ast) then
+        local e
+        -- 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 = 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({expr(tostring(ast), 'literal')}, parent, opts)
+    elseif type(ast) == 'number' then
+        local n = ('%.17g'):format(ast)
+        exprs = handleCompileOpts({expr(n, 'literal')}, parent, opts)
+    elseif type(ast) == 'string' then
+        local s = serializeString(ast)
+        exprs = handleCompileOpts({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 keys = {}
+        for k, _ in pairs(ast) do -- Write other keys.
+            if type(k) ~= 'number' or math.floor(k) ~= k or k < 1 or k > #ast then
+                local kstr
+                if type(k) == 'string' and isValidLuaIdentifier(k) then
+                    kstr = k
+                else
+                    kstr = '[' .. tostring(compile1(k, scope, parent, {nval = 1})[1]) .. ']'
+                end
+                table.insert(keys, { kstr, k })
+            end
+        end
+        table.sort(keys, function (a, b) return a[1] < b[1] end)
+        for _, k in ipairs(keys) do
+            local v = ast[k[2]]
+            buffer[#buffer + 1] = ('%s = %s'):format(
+                k[1], tostring(compile1(v, scope, parent, {nval = 1})[1]))
+        end
+        local tbl = '{' .. table.concat(buffer, ', ') ..'}'
+        exprs = handleCompileOpts({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
+
+-- SPECIALS --
+
+-- 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 = gensym(scope)
+        emit(parent, ('local %s = %s'):format(s, tostring(val)), ast)
+        return expr(s, 'sym')
+    else
+        return val
+    end
+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"
+
+    -- Get Lua source for symbol, and check for errors
+    local function getname(symbol, up1)
+        local raw = symbol[1]
+        assertCompile(not (nomulti and isMultiSym(raw)),
+            'did not expect multisym', up1)
+        if declaration then
+            return declareLocal(symbol, {var = isvar}, scope, symbol)
+        else
+            local parts = isMultiSym(raw) or {raw}
+            local meta = scope.symmeta[parts[1]]
+            if #parts == 1 and not forceset then
+                assertCompile(not(forceglobal and meta),
+                    'expected global, found var', up1)
+                assertCompile(meta or not noundef,
+                    'expected local var ' .. parts[1], up1)
+                assertCompile(not (meta and not meta.var),
+                    'expected local var', up1)
+            end
+            return symbolToExpression(symbol, scope)[1]
+        end
+    end
+
+    -- Recursive auxiliary function
+    local function destructure1(left, rightexprs, up1)
+        if isSym(left) and left[1] ~= "nil" then
+            emit(parent, setter:format(getname(left, up1), exprs1(rightexprs)), left)
+        elseif isTable(left) then -- table destructuring
+            local s = gensym(scope)
+            emit(parent, ("local %s = %s"):format(s, exprs1(rightexprs)), left)
+            for k, v in pairs(left) do
+                if isSym(left[k]) and left[k][1] == "&" then
+                    assertCompile(type(k) == "number" and not left[k+2],
+                        "expected rest argument in final position", left)
+                    local subexpr = expr(('{(table.unpack or unpack)(%s, %s)}'):format(s, k),
+                        'expression')
+                    destructure1(left[k+1], {subexpr}, left)
+                    return
+                else
+                    if type(k) ~= "number" then k = serializeString(k) end
+                    local subexpr = expr(('%s[%s]'):format(s, k), 'expression')
+                    destructure1(v, {subexpr}, left)
+                end
+            end
+        elseif isList(left) then -- values destructuring
+            local leftNames, tables = {}, {}
+            for i, name in ipairs(left) do
+                local symname
+                if 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, expr(symname, 'sym')}
+                end
+                table.insert(leftNames, symname)
+            end
+            emit(parent, setter:
+            format(table.concat(leftNames, ", "), exprs1(rightexprs)), left)
+            for _, pair in pairs(tables) do -- recurse if left-side tables found
+                destructure1(pair[1], {pair[2]}, left)
+            end
+        else
+            assertCompile(false, 'unable to destructure ' .. tostring(left), up1)
+        end
+    end
+
+    local rexps = compile1(from, scope, parent)
+    local ret = destructure1(to, rexps, ast)
+    return ret
+end
+
+-- 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.
+local function values(ast, scope, parent)
+    local len = #ast
+    local exprs = {}
+    for i = 2, len do
+        local subexprs = compile1(ast[i], scope, parent, {})
+        exprs[#exprs + 1] = subexprs[1] or expr('nil', 'literal')
+        if i == len then
+            for j = 2, #subexprs do
+                exprs[#exprs + 1] = subexprs[j]
+            end
+        else
+            -- Emit sub expression only for side effects
+            keepSideEffects(subexprs, parent, 2, ast)
+        end
+    end
+    return exprs
+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 = makeScope(scope)
+    for i = start, len do
+        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)
+    start = start or 2
+    subScope = subScope or 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 = gensym(scope)
+                syms[i] = s
+                retexprs[i] = expr(s, 'sym')
+            end
+            outerTarget = table.concat(syms, ', ')
+            emit(parent, ('local %s'):format(outerTarget), ast)
+            emit(parent, 'do', ast)
+        else
+            -- We will use an IIFE for the do
+            local fname = gensym(scope)
+            local fargs = scope.vararg and '...' or ''
+            emit(parent, ('local function %s(%s)'):format(fname, fargs), ast)
+            retexprs = expr(fname .. '(' .. fargs .. ')', 'statement')
+            outerTail = true
+            outerTarget = nil
+        end
+    else
+        emit(parent, 'do', ast)
+    end
+    -- Compile the body
+    if start > len then
+        -- In the unlikely case we do a do with no arguments.
+        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
+            }
+            local subexprs = compile1(ast[i], subScope, chunk, subopts)
+            if i ~= len then
+                keepSideEffects(subexprs, parent, nil, ast[i])
+            end
+        end
+    end
+    emit(parent, chunk, ast)
+    emit(parent, 'end', ast)
+    return retexprs
+end
+
+SPECIALS['do'] = doImpl
+SPECIALS['values'] = values
+
+-- 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 = makeScope(scope)
+    local fChunk = {}
+    local index = 2
+    local fnName = isSym(ast[index])
+    local isLocalFn
+    fScope.vararg = false
+    if fnName and fnName[1] ~= 'nil' then
+        isLocalFn = not isMultiSym(fnName[1])
+        if isLocalFn then
+            fnName = declareLocal(fnName, {}, scope, ast)
+        else
+            fnName = symbolToExpression(fnName, scope)[1]
+        end
+        index = index + 1
+    else
+        isLocalFn = true
+        fnName = gensym(scope)
+    end
+    local argList = assertCompile(isTable(ast[index]),
+                                  'expected vector arg list [a b ...]', ast)
+    local argNameList = {}
+    for i = 1, #argList do
+        if isVarg(argList[i]) then
+            assertCompile(i == #argList, "expected vararg in last parameter position", ast)
+            argNameList[i] = '...'
+            fScope.vararg = true
+        elseif(isSym(argList[i]) and argList[i][1] ~= "nil"
+               and not isMultiSym(argList[i][1])) then
+            argNameList[i] = declareLocal(argList[i], {}, fScope, ast)
+        elseif isTable(argList[i]) then
+            local raw = sym(gensym(scope))
+            argNameList[i] = declareLocal(raw, {}, fScope, ast)
+            destructure(argList[i], raw, ast, fScope, fChunk,
+                        { declaration = true, nomulti = true })
+        else
+            assertCompile(false, 'expected symbol for function parameter', ast)
+        end
+    end
+    for i = index + 1, #ast do
+        compile1(ast[i], fScope, fChunk, {
+            tail = i == #ast,
+            nval = i ~= #ast and 0 or nil
+        })
+    end
+    if isLocalFn then
+        emit(parent, ('local function %s(%s)')
+                 :format(fnName, table.concat(argNameList, ', ')), ast)
+    else
+        emit(parent, ('%s = function(%s)')
+                 :format(fnName, table.concat(argNameList, ', ')), ast)
+    end
+    emit(parent, fChunk, ast)
+    emit(parent, 'end', ast)
+    return expr(fnName, 'sym')
+end
+
+SPECIALS['luaexpr'] = function(ast)
+    return tostring(ast[2])
+end
+
+SPECIALS['luastatement'] = function(ast)
+    return expr(tostring(ast[2]), 'statement')
+end
+
+-- Wrapper for table access
+SPECIALS['.'] = function(ast, scope, parent)
+    local len = #ast
+    assertCompile(len > 1, "expected table argument", ast)
+    local lhs = 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 isValidLuaIdentifier(index) then
+                table.insert(indices, '.' .. index)
+            else
+                index = compile1(index, scope, parent, {nval = 1})[1]
+                table.insert(indices, '[' .. tostring(index) .. ']')
+            end
+        end
+        -- extra parens are needed for table literals
+        if isTable(ast[2]) then
+            return '(' .. tostring(lhs[1]) .. ')' .. table.concat(indices)
+        else
+            return tostring(lhs[1]) .. table.concat(indices)
+        end
+    end
+end
+
+SPECIALS['global'] = function(ast, scope, parent)
+    assertCompile(#ast == 3, "expected name and value", ast)
+    if allowedGlobals then table.insert(allowedGlobals, ast[2][1]) end
+    destructure(ast[2], ast[3], ast, scope, parent, {
+        nomulti = true,
+        forceglobal = true
+    })
+end
+
+SPECIALS['set'] = function(ast, scope, parent)
+    assertCompile(#ast == 3, "expected name and value", ast)
+    destructure(ast[2], ast[3], ast, scope, parent, {
+        noundef = true
+    })
+end
+
+SPECIALS['set-forcibly!'] = function(ast, scope, parent)
+    assertCompile(#ast == 3, "expected name and value", ast)
+    destructure(ast[2], ast[3], ast, scope, parent, {
+        forceset = true
+    })
+end
+
+SPECIALS['local'] = function(ast, scope, parent)
+    assertCompile(#ast == 3, "expected name and value", ast)
+    destructure(ast[2], ast[3], ast, scope, parent, {
+        declaration = true,
+        nomulti = true
+    })
+end
+
+SPECIALS['var'] = function(ast, scope, parent)
+    assertCompile(#ast == 3, "expected name and value", ast)
+    destructure(ast[2], ast[3], ast, scope, parent, {
+        declaration = true,
+        nomulti = true,
+        isvar = true
+    })
+end
+
+SPECIALS['let'] = function(ast, scope, parent, opts)
+    local bindings = ast[2]
+    assertCompile(isList(bindings) or isTable(bindings),
+                  'expected table for destructuring', ast)
+    assertCompile(#bindings % 2 == 0,
+                  'expected even number of name/value bindings', ast)
+    assertCompile(#ast >= 3, 'missing body expression', ast)
+    local subScope = makeScope(scope)
+    local subChunk = {}
+    for i = 1, #bindings, 2 do
+        destructure(bindings[i], bindings[i + 1], ast, subScope, subChunk, {
+            declaration = true,
+            nomulti = true
+        })
+    end
+    return doImpl(ast, scope, parent, opts, 3, subChunk, subScope)
+end
+
+-- For setting items in a table
+SPECIALS['tset'] = function(ast, scope, parent)
+    assertCompile(#ast > 3,
+                  ('tset form needs table, key, and value'), ast)
+    local root = compile1(ast[2], scope, parent, {nval = 1})[1]
+    local keys = {}
+    for i = 3, #ast - 1 do
+        local key = compile1(ast[i], scope, parent, {nval = 1})[1]
+        keys[#keys + 1] = tostring(key)
+    end
+    local value = compile1(ast[#ast], scope, parent, {nval = 1})[1]
+    emit(parent, ('%s[%s] = %s'):format(tostring(root),
+                                        table.concat(keys, ']['),
+                                        tostring(value)), ast)
+end
+
+-- The if special form behaves like the cond form in
+-- many languages
+SPECIALS['if'] = function(ast, scope, parent, opts)
+    local doScope = makeScope(scope)
+    local branches = {}
+    local elseBranch = nil
+
+    -- Calculate some external stuff. Optimizes for tail calls and what not
+    local outerTail = true
+    local outerTarget = nil
+    local wrapper = 'iife'
+    if opts.tail then
+        wrapper = 'none'
+    end
+
+    -- Compile bodies and conditions
+    local bodyOpts = {
+        tail = outerTail,
+        target = outerTarget
+    }
+    local function compileBody(i)
+        local chunk = {}
+        local cscope = makeScope(doScope)
+        compile1(ast[i], cscope, chunk, bodyOpts)
+        return {
+            chunk = chunk,
+            scope = cscope
+        }
+    end
+    for i = 2, #ast - 1, 2 do
+        local condchunk = {}
+        local cond =  compile1(ast[i], doScope, condchunk, {nval = 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 = 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 condLine = fstr:format(tostring(branch.cond[1]))
+        if branch.nested then
+            emit(lastBuffer, branch.condchunk, ast)
+        else
+            for _, v in ipairs(branch.condchunk) do emit(lastBuffer, v, ast) end
+        end
+        emit(lastBuffer, condLine, ast)
+        emit(lastBuffer, branch.chunk, ast)
+        if i == #branches then
+            if hasElse then
+                emit(lastBuffer, 'else', ast)
+                emit(lastBuffer, elseBranch.chunk, ast)
+            end
+            emit(lastBuffer, 'end', ast)
+        elseif not branches[i + 1].nested then
+            emit(lastBuffer, 'else', ast)
+            local nextBuffer = {}
+            emit(lastBuffer, nextBuffer, ast)
+            emit(lastBuffer, 'end', ast)
+            lastBuffer = nextBuffer
+        end
+    end
+
+    if wrapper == 'iife' then
+        local iifeargs = scope.vararg and '...' or ''
+        emit(parent, ('local function %s(%s)'):format(tostring(s), iifeargs), ast)
+        emit(parent, buffer, ast)
+        emit(parent, 'end', ast)
+        return expr(('%s(%s)'):format(tostring(s), iifeargs), 'statement')
+    elseif wrapper == 'none' then
+        -- Splice result right into code
+        for i = 1, #buffer do
+            emit(parent, buffer[i], ast)
+        end
+        return {returned = true}
+    end
+end
+
+-- (each [k v (pairs t)] body...) => []
+SPECIALS['each'] = function(ast, scope, parent)
+    local binding = assertCompile(isTable(ast[2]), 'expected binding table', ast)
+    local iter = table.remove(binding, #binding) -- last item is iterator call
+    local bindVars = {}
+    local destructures = {}
+    for _, v in ipairs(binding) do
+        assertCompile(isSym(v) or isTable(v),
+                      'expected iterator symbol or table', ast)
+        if(isSym(v)) then
+            table.insert(bindVars, declareLocal(v, {}, scope, ast))
+        else
+            local raw = sym(gensym(scope))
+            destructures[raw] = v
+            table.insert(bindVars, declareLocal(raw, {}, scope, ast))
+        end
+    end
+    emit(parent, ('for %s in %s do'):format(
+             table.concat(bindVars, ', '),
+             tostring(compile1(iter, scope, parent, {nval = 1})[1])), ast)
+    local chunk = {}
+    for raw, args in pairs(destructures) do
+        destructure(args, raw, ast, scope, chunk,
+                    { declaration = true, nomulti = true })
+    end
+    compileDo(ast, scope, chunk, 3)
+    emit(parent, chunk, ast)
+    emit(parent, 'end', ast)
+end
+
+-- (while condition body...) => []
+SPECIALS['while'] = function(ast, scope, parent)
+    local len1 = #parent
+    local condition = compile1(ast[2], scope, parent, {nval = 1})[1]
+    local len2 = #parent
+    local subChunk = {}
+    if len1 ~= len2 then
+        -- Compound condition
+        emit(parent, 'while true do', ast)
+        -- Move new compilation to subchunk
+        for i = len1 + 1, len2 do
+            subChunk[#subChunk + 1] = parent[i]
+            parent[i] = nil
+        end
+        emit(parent, ('if %s then break end'):format(condition[1]), ast)
+    else
+        -- Simple condition
+        emit(parent, 'while ' .. tostring(condition) .. ' do', ast)
+    end
+    compileDo(ast, makeScope(scope), subChunk, 3)
+    emit(parent, subChunk, ast)
+    emit(parent, 'end', ast)
+end
+
+SPECIALS['for'] = function(ast, scope, parent)
+    local ranges = assertCompile(isTable(ast[2]), 'expected binding table', ast)
+    local bindingSym = assertCompile(isSym(table.remove(ast[2], 1)),
+                                     'expected iterator symbol', ast)
+    local rangeArgs = {}
+    for i = 1, math.min(#ranges, 3) do
+        rangeArgs[i] = tostring(compile1(ranges[i], scope, parent, {nval = 1})[1])
+    end
+    emit(parent, ('for %s = %s do'):format(
+             declareLocal(bindingSym, {}, scope, ast),
+             table.concat(rangeArgs, ', ')), ast)
+    local chunk = {}
+    compileDo(ast, scope, chunk, 3)
+    emit(parent, chunk, ast)
+    emit(parent, 'end', ast)
+end
+
+SPECIALS[':'] = function(ast, scope, parent)
+    assertCompile(#ast >= 3, 'expected at least 3 arguments', ast)
+    -- Compile object
+    local objectexpr = compile1(ast[2], scope, parent, {nval = 1})[1]
+    -- Compile method selector
+    local methodstring
+    local methodident = false
+    if type(ast[3]) == 'string' and isValidLuaIdentifier(ast[3]) then
+        methodident = true
+        methodstring = ast[3]
+    else
+        methodstring = tostring(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 = compile1(ast[i], scope, parent, {
+            nval = i ~= #ast and 1 or nil
+        })
+        for j = 1, #subexprs do
+            args[#args + 1] = tostring(subexprs[j])
+        end
+    end
+    local fstring
+    if methodident then
+        fstring = objectexpr.type == 'literal'
+            and '(%s):%s(%s)'
+            or '%s:%s(%s)'
+    else
+        -- Make object first argument
+        table.insert(args, 1, tostring(objectexpr))
+        fstring = objectexpr.type == 'sym'
+            and '%s[%s](%s)'
+            or '(%s)[%s](%s)'
+    end
+    return expr(fstring:format(
+        tostring(objectexpr),
+        methodstring,
+        table.concat(args, ', ')), 'statement')
+end
+
+local function defineArithmeticSpecial(name, zeroArity, unaryPrefix)
+    local paddedOp = ' ' .. name .. ' '
+    SPECIALS[name] = function(ast, scope, parent)
+        local len = #ast
+        if len == 1 then
+            assertCompile(zeroArity ~= nil, 'Expected more than 0 arguments', ast)
+            return expr(zeroArity, 'literal')
+        else
+            local operands = {}
+            for i = 2, len do
+                local subexprs = compile1(ast[i], scope, parent, {
+                    nval = (i == 1 and 1 or nil)
+                })
+                for j = 1, #subexprs do
+                    operands[#operands + 1] = tostring(subexprs[j])
+                end
+            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
+end
+
+defineArithmeticSpecial('+', '0')
+defineArithmeticSpecial('..', "''")
+defineArithmeticSpecial('^')
+defineArithmeticSpecial('-', nil, '')
+defineArithmeticSpecial('*', '1')
+defineArithmeticSpecial('%')
+defineArithmeticSpecial('/', nil, '1')
+defineArithmeticSpecial('//', nil, '1')
+defineArithmeticSpecial('or', 'false')
+defineArithmeticSpecial('and', 'true')
+
+local function defineComparatorSpecial(name, realop)
+    local op = realop or name
+    SPECIALS[name] = function(ast, scope, parent)
+        local len = #ast
+        assertCompile(len > 2, 'expected at least two arguments', ast)
+        local lhs = compile1(ast[2], scope, parent, {nval = 1})[1]
+        local lastval = 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(compile1(ast[i], scope, parent, {nval = 1})[1],
+                                     ast[i], scope, parent)
+                out = (out .. " and (%s %s %s)"):
+                    format(tostring(lastval), op, tostring(nextval))
+                lastval = nextval
+            end
+            out = '(' .. out .. ')'
+        end
+        return out
+    end
+end
+
+defineComparatorSpecial('>')
+defineComparatorSpecial('<')
+defineComparatorSpecial('>=')
+defineComparatorSpecial('<=')
+defineComparatorSpecial('=', '==')
+defineComparatorSpecial('~=')
+
+local function defineUnarySpecial(op, realop)
+    SPECIALS[op] = function(ast, scope, parent)
+        assertCompile(#ast == 2, 'expected one argument', ast)
+        local tail = compile1(ast[2], scope, parent, {nval = 1})
+        return (realop or op) .. tostring(tail[1])
+    end
+end
+
+defineUnarySpecial('not', 'not ')
+defineUnarySpecial('#')
+
+-- Covert a macro function to a special form
+local function macroToSpecial(mac)
+    return function(ast, scope, parent, opts)
+        local ok, transformed = pcall(mac, unpack(ast, 2))
+        assertCompile(ok, transformed, ast)
+        return compile1(transformed, scope, parent, opts)
+    end
+end
+
+local function compile(ast, options)
+    options = options or {}
+    local oldGlobals = allowedGlobals
+    allowedGlobals = options.allowedGlobals
+    if options.indent == nil then options.indent = '  ' end
+    local chunk = {}
+    local scope = options.scope or makeScope(GLOBAL_SCOPE)
+    local exprs = compile1(ast, scope, chunk, {tail = true})
+    keepSideEffects(exprs, chunk, nil, ast)
+    allowedGlobals = oldGlobals
+    return flatten(chunk, options)
+end
+
+-- map a function across all pairs in a table
+local function quoteTmap(f, t)
+    local res = {}
+    for k,v in pairs(t) do
+        local nk, nv = f(k, v)
+        if nk then
+            res[nk] = nv
+        end
+    end
+    return res
+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 pairs(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
+    -- symbol
+    if isSym(form) then
+        assertCompile(not runtime, "symbols may only be used at compile time", form)
+        return ("sym('%s')"):format(deref(form))
+    -- unquote
+    elseif isList(form) and isSym(form[1]) and (deref(form[1]) == 'unquote') then
+        local payload = form[2]
+        local res = unpack(compile1(payload, scope, parent))
+        return res[1]
+    -- list
+    elseif isList(form) then
+        assertCompile(not runtime, "lists may only be used at compile time", form)
+        local mapped = quoteTmap(entryTransform(no, q), form)
+        return 'list(' .. mixedConcat(mapped, ", ") .. ')'
+    -- table
+    elseif type(form) == 'table' then
+        local mapped = quoteTmap(entryTransform(q, q), form)
+        return '{' .. mixedConcat(mapped, ", ") .. '}'
+    -- string
+    elseif type(form) == 'string' then
+        return serializeString(form)
+    else
+        return tostring(form)
+    end
+end
+
+SPECIALS['quote'] = function(ast, scope, parent)
+    assertCompile(#ast == 2, "quote only takes a single form")
+    local runtime, thisScope = true, scope
+    while thisScope do
+        thisScope = thisScope.parent
+        if thisScope == COMPILER_SCOPE then runtime = false end
+    end
+    return doQuote(ast[2], scope, parent, runtime)
+end
+
+local function compileStream(strm, options)
+    options = options or {}
+    local oldGlobals = allowedGlobals
+    allowedGlobals = options.allowedGlobals
+    if options.indent == nil then options.indent = '  ' end
+    local scope = options.scope or makeScope(GLOBAL_SCOPE)
+    local vals = {}
+    for ok, val in parser(strm, options.filename) do
+        if not ok then break end
+        vals[#vals + 1] = val
+    end
+    local chunk = {}
+    for i = 1, #vals do
+        local exprs = compile1(vals[i], scope, chunk, {
+            tail = i == #vals
+        })
+        keepSideEffects(exprs, chunk, nil, vals[i])
+    end
+    allowedGlobals = oldGlobals
+    return flatten(chunk, options)
+end
+
+local function compileString(str, options)
+    local strm = stringStream(str)
+    return compileStream(strm, options)
+end
+
+---
+--- Evaluation
+---
+
+-- 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 = globalUnmangling(key)
+            end
+            return env[key]
+        end,
+        __newindex = function(_, key, value)
+            if type(key) == 'string' then
+                key = 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 pt = {}
+            for key, value in pairs(env) do
+                if type(key) == 'string' then
+                    pt[globalUnmangling(key)] = value
+                else
+                    pt[key] = value
+                end
+            end
+            return next, pt, nil
+        end,
+    })
+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
+        table.insert(lines, msg)
+    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
+
+local function currentGlobalNames(env)
+    local names = {}
+    for k in pairs(env or _G) do
+       k = globalUnmangling(k)
+       table.insert(names, k)
+    end
+    return names
+end
+
+local function eval(str, options, ...)
+    options = options or {}
+    -- 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 options.allowedGlobals == nil and not getmetatable(options.env) then
+        options.allowedGlobals = currentGlobalNames(options.env)
+    end
+    local env = options.env and wrapEnv(options.env)
+    local luaSource = compileString(str, options)
+    local loader = loadCode(luaSource, env,
+        options.filename and ('@' .. options.filename) or str)
+    return loader(...)
+end
+
+local function dofileFennel(filename, options, ...)
+    options = options or {sourcemap = true}
+    if options.allowedGlobals == nil then
+        options.allowedGlobals = currentGlobalNames(options.env)
+    end
+    local f = assert(io.open(filename, "rb"))
+    local source = f:read("*all"):gsub("^#![^\n]*\n", "")
+    f:close()
+    options.filename = options.filename or filename
+    return eval(source, options, ...)
+end
+
+-- Implements a configurable repl
+local function repl(options)
+
+    local opts = options or {}
+    -- This would get set for us when calling eval, but we want to seed it
+    -- with a value that is persistent so it doesn't get reset on each eval.
+    if opts.allowedGlobals == nil then
+        options.allowedGlobals = currentGlobalNames(opts.env)
+    end
+
+    local env = opts.env and wrapEnv(opts.env) or setmetatable({}, {
+        __index = _ENV or _G
+    })
+
+    local function defaultReadChunk(parserState)
+        io.write(parserState.stackSize > 0 and '.. ' or '>> ')
+        io.flush()
+        local input = io.read()
+        return input and input .. '\n'
+    end
+
+    local function defaultOnValues(xs)
+        io.write(table.concat(xs, '\t'))
+        io.write('\n')
+    end
+
+    local function defaultOnError(errtype, err, luaSource)
+        if (errtype == 'Lua Compile') then
+            io.write('Bad code generated - likely a bug with the compiler:\n')
+            io.write('--- Generated Lua Start ---\n')
+            io.write(luaSource .. '\n')
+            io.write('--- Generated Lua End ---\n')
+        end
+        if (errtype == 'Runtime') then
+            io.write(traceback(err, 4))
+            io.write('\n')
+        else
+            io.write(('%s error: %s\n'):format(errtype, tostring(err)))
+        end
+    end
+
+    -- Read options
+    local readChunk = opts.readChunk or defaultReadChunk
+    local onValues = opts.onValues or defaultOnValues
+    local onError = opts.onError or defaultOnError
+    local pp = opts.pp or tostring
+
+    -- Make parser
+    local bytestream, clearstream = granulate(readChunk)
+    local chars = {}
+    local read, reset = parser(function (parserState)
+        local c = bytestream(parserState)
+        chars[#chars + 1] = c
+        return c
+    end)
+
+    local envdbg = (opts.env or _G)["debug"]
+    -- if the environment doesn't support debug.getlocal you can't save locals
+    local saveLocals = opts.saveLocals ~= false and envdbg and envdbg.getlocal
+    local saveSource = table.
+       concat({"local ___i___ = 1",
+               "while true do",
+               " local name, value = debug.getlocal(1, ___i___)",
+               " if(name and name ~= \"___i___\") then",
+               " ___replLocals___[name] = value",
+               " ___i___ = ___i___ + 1",
+               " else break end end"}, "\n")
+
+    local spliceSaveLocals = function(luaSource)
+        -- we do some source munging in order to save off locals from each chunk
+        -- and reintroduce them to the beginning of the next chunk, allowing
+        -- locals to work in the repl the way you'd expect them to.
+        env.___replLocals___ = env.___replLocals___ or {}
+        local splicedSource = {}
+        for line in luaSource:gmatch("([^\n]+)\n?") do
+            table.insert(splicedSource, line)
+        end
+        -- reintroduce locals from the previous time around
+        local bind = "local %s = ___replLocals___['%s']"
+        for name in pairs(env.___replLocals___) do
+            table.insert(splicedSource, 1, bind:format(name, name))
+        end
+        -- save off new locals at the end - if safe to do so (i.e. last line is a return)
+        if (string.match(splicedSource[#splicedSource], "^ *return .*$")) then
+            if (#splicedSource > 1) then
+                table.insert(splicedSource, #splicedSource, saveSource)
+            end
+        end
+        return table.concat(splicedSource, "\n")
+    end
+
+    local scope = makeScope(GLOBAL_SCOPE)
+
+    -- REPL loop
+    while true do
+        chars = {}
+        local ok, parseok, x = pcall(read)
+        local srcstring = string.char(unpack(chars))
+        if not ok then
+            onError('Parse', parseok)
+            clearstream()
+            reset()
+        else
+            if not parseok then break end -- eof
+            local compileOk, luaSource = pcall(compile, x, {
+                sourcemap = opts.sourcemap,
+                source = srcstring,
+                scope = scope,
+            })
+            if not compileOk then
+                clearstream()
+                onError('Compile', luaSource) -- luaSource is error message in this case
+            else
+                if saveLocals then
+                    luaSource = spliceSaveLocals(luaSource)
+                end
+                local luacompileok, loader = pcall(loadCode, luaSource, env)
+                if not luacompileok then
+                    clearstream()
+                    onError('Lua Compile', loader, luaSource)
+                else
+                    local loadok, ret = xpcall(function () return {loader()} end,
+                        function (runtimeErr)
+                            onError('Runtime', runtimeErr)
+                        end)
+                    if loadok then
+                        env._ = ret[1]
+                        env.__ = ret
+                        for i = 1, #ret do ret[i] = pp(ret[i]) end
+                        onValues(ret)
+                    end
+                end
+            end
+        end
+    end
+end
+
+local macroLoaded = {}
+
+local module = {
+    parser = parser,
+    granulate = granulate,
+    stringStream = stringStream,
+    compile = compile,
+    compileString = compileString,
+    compileStream = compileStream,
+    compile1 = compile1,
+    mangle = globalMangling,
+    unmangle = globalUnmangling,
+    list = list,
+    sym = sym,
+    varg = varg,
+    scope = makeScope,
+    gensym = gensym,
+    eval = eval,
+    repl = repl,
+    dofile = dofileFennel,
+    macroLoaded = macroLoaded,
+    path = "./?.fnl;./?/init.fnl",
+    traceback = traceback,
+    version = "0.1.1-dev",
+}
+
+local function searchModule(modulename)
+    modulename = modulename:gsub("%.", "/")
+    for path in string.gmatch(module.path..";", "([^;]*);") do
+        local filename = path:gsub("%?", modulename)
+        local file = io.open(filename, "rb")
+        if(file) then
+            file:close()
+            return filename
+        end
+    end
+end
+
+module.makeSearcher = function(options)
+   return function(modulename)
+      local opts = {}
+      for k,v in pairs(options or {}) do opts[k] = v end
+      local filename = searchModule(modulename)
+      if filename then
+         return function(modname)
+            return 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
+
+local function makeCompilerEnv(ast, scope, parent)
+    return setmetatable({
+        -- State of compiler if needed
+        _SCOPE = scope,
+        _CHUNK = parent,
+        _AST = ast,
+        _IS_COMPILER = true,
+        _SPECIALS = SPECIALS,
+        _VARARG = VARARG,
+        -- Expose the module in the compiler
+        fennel = module,
+        -- Useful for macros and meta programming. All of Fennel can be accessed
+        -- via fennel.myfun, for example (fennel.eval "(print 1)").
+        list = list,
+        sym = sym,
+        unpack = unpack,
+        gensym = function() return sym(gensym(scope)) end,
+        ["list?"] = isList,
+        ["multi-sym?"] = isMultiSym,
+        ["sym?"] = isSym,
+        ["table?"] = isTable,
+        ["varg?"] = isVarg,
+        ["in-scope?"] = function(symbol)
+            return scope.manglings[symbol]
+        end
+    }, { __index = _ENV or _G })
+end
+
+local function macroGlobals(env, globals)
+    local allowed = {}
+    for k in pairs(env) do
+        local g = globalUnmangling(k)
+        table.insert(allowed, g)
+    end
+    if globals then
+        for _, k in pairs(globals) do
+            table.insert(allowed, k)
+        end
+    end
+    return allowed
+end
+
+local function addMacros(macros, ast, scope)
+    assertCompile(isTable(macros), 'expected macros to be table', ast)
+    for k, v in pairs(macros) do
+        scope.specials[k] = macroToSpecial(v)
+    end
+end
+
+local function loadMacros(modname, ast, scope, parent)
+    local filename = assertCompile(searchModule(modname),
+                                   modname .. " not found.", ast)
+    local env = makeCompilerEnv(ast, scope, parent)
+    local globals = macroGlobals(env, currentGlobalNames())
+    return dofileFennel(filename, { env = env, allowedGlobals = globals,
+                                    scope = COMPILER_SCOPE })
+end
+
+SPECIALS['require-macros'] = function(ast, scope, parent)
+    assertCompile(#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
+
+local function evalCompiler(ast, scope, parent)
+    local luaSource = compile(ast, { scope = makeScope(COMPILER_SCOPE) })
+    local loader = loadCode(luaSource, wrapEnv(makeCompilerEnv(ast, scope, parent)))
+    return loader()
+end
+
+SPECIALS['macros'] = function(ast, scope, parent)
+    assertCompile(#ast == 2, "Expected one table argument", ast)
+    local macros = evalCompiler(ast[2], scope, parent)
+    addMacros(macros, ast, scope, parent)
+end
+
+SPECIALS['eval-compiler'] = function(ast, scope, parent)
+    local oldFirst = ast[1]
+    ast[1] = sym('do')
+    local val = evalCompiler(ast, scope, parent)
+    ast[1] = oldFirst
+    return val
+end
+
+-- Load standard macros
+local stdmacros = [===[
+{"->" (fn [val ...]
+        (var x val)
+        (each [_ elt (ipairs [...])]
+          (table.insert elt 2 x)
+          (set x elt))
+        x)
+ "->>" (fn [val ...]
+         (var x val)
+         (each [_ elt (pairs [...])]
+           (table.insert elt x)
+           (set x elt))
+         x)
+ "-?>" (fn [val ...]
+         (if (= 0 (# [...]))
+             val
+             (let [els [...]
+                   el (table.remove els 1)
+                   tmp (gensym)]
+               (table.insert el 2 tmp)
+               `(let [@tmp @val]
+                  (if @tmp
+                      (-?> @el @(unpack els))
+                      @tmp)))))
+ "-?>>" (fn [val ...]
+          (if (= 0 (# [...]))
+              val
+              (let [els [...]
+                    el (table.remove els 1)
+                    tmp (gensym)]
+                (table.insert el tmp)
+                `(let [@tmp @val]
+                   (if @tmp
+                       (-?>> @el @(unpack els))
+                       @tmp)))))
+ :doto (fn [val ...]
+         (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 ...]
+         (assert body1 "expected body")
+         `(if @condition
+              (do @body1 @...)))
+ :partial (fn [f ...]
+            (let [body (list f ...)]
+              (table.insert body _VARARG)
+              `(fn [@_VARARG] @body)))
+ :lambda (fn [...]
+           (let [args [...]
+                 has-internal-name? (sym? (. args 1))
+                 arglist (if has-internal-name? (. args 2) (. args 1))
+                 arity-check-position (if has-internal-name? 3 2)]
+             (assert (> (# args) 1) "missing body expression")
+             (each [i a (ipairs arglist)]
+               (if (and (not (: (tostring a) :match "^?"))
+                        (~= (tostring a) "..."))
+                   (table.insert args arity-check-position
+                                 `(assert (~= nil @a)
+                                          (: "Missing argument %s on %s:%s"
+                                             :format @(tostring a)
+                                             @(or a.filename "unknown")
+                                             @(or a.line "?"))))))
+             `(fn @(unpack args))))
+ :match
+(fn match [val ...]
+  ;; 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 (and (sym? pattern) ; unification with outer locals (or nil)
+               (or (in-scope? pattern)
+                   (= :nil (tostring pattern))))
+          (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)
+          (do (if (~= (tostring pattern) "_")
+                  (tset unifications (tostring pattern) val))
+              (values (if (: (tostring pattern) :find "^?")
+                          true `(~= @(sym :nil) @val))
+                      [pattern val]))
+
+          ;; 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)]
+              (assert (not (varg? pat)) "TODO: match against varg not implemented")
+              (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 (# 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 (# 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 (~= 0 (% (# clauses) 2)) ; treat odd final clause as default
+        (table.insert clauses (# 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
+    local env = makeCompilerEnv(nil, COMPILER_SCOPE, {})
+    for name, fn in pairs(eval(stdmacros, {
+        env = env,
+        scope = makeScope(COMPILER_SCOPE),
+        allowedGlobals = macroGlobals(env, currentGlobalNames()),
+    })) do
+        SPECIALS[name] = macroToSpecial(fn)
+    end
+end
+SPECIALS['λ'] = SPECIALS['lambda']
+
+return module

A  => readme.md +17 -0
@@ 1,17 @@
+# Shevek
+
+> All you have is what you are, and what you give.
+
+A simple nREPL client.
+
+## Usage
+
+    $ shevek PORT
+
+## License
+
+Copyright © 2015-2018 Phil Hagelberg
+
+Released under the terms of the GNU Lesser General Public License
+version 3 or later; see the file LICENSE.
+

A  => shevek.fnl +84 -0
@@ 1,84 @@
+(local socket (require :socket))
+(local bencode (require :bencode))
+
+(local active-requests {})
+(var counter 0)
+(var session nil)
+(var ns nil)
+(var prompt "=> ")
+
+(λ count [tbl]
+  (var i 0)
+  (each [_ (pairs tbl)] (set i (+ 1 i)))
+  i)
+
+(λ contains? [tbl item ?n]
+  (or (= item (. tbl (or ?n 1)))
+      (if (<= (or ?n 1) (# tbl))
+          (contains? tbl item (+ 1 (or ?n 1))))))
+
+(λ send [msg conn]
+  (set (msg.id counter) (values counter (+ counter 1)))
+  (tset active-requests msg.id true)
+  (when (not msg.session)
+    (set msg.session session))
+  (assert (: conn :send (bencode.encode msg))))
+
+(λ send-input [?session]
+  (let [input (io.read)]
+    (send {:op :stdin
+           :session ?session
+           :stdin (if (= nil input) "" input)})))
+
+(λ handler [response]
+  (when response.new-session
+    (print "Connected.")
+    (set session response.new-session))
+
+  (when response.err (print response.err))
+  (when response.out (print response.out))
+  (when response.value (print response.value))
+
+  (when response.ns
+    (set ns response.ns)
+    (set prompt (.. response.ns "=> ")))
+
+  (when response.status
+    (when (contains? response.status :interrupted)
+      (print "Evaluation interrupted.")
+      (tset active-requests response.id nil))
+    (when (contains? response.status :done)
+      (tset active-requests response.id nil))
+    (when (contains? response.status :needs-input)
+      (send-input response.session))))
+
+(λ receive [conn]
+  (let [(data err part) (: conn :receive "*a")]
+    (when (or data (and part (~= part "")))
+      (let [(decodeds d-err) (bencode.decode_all (or data part))]
+        (if decodeds
+            (each [_ decoded (ipairs decodeds)]
+              (handler decoded))
+            (print (.. "Decoding error: " d-err (or data part) "\n"))))
+      true)))
+
+(local conn (let [port (tonumber (. arg 1))
+                  conn (assert (socket.connect "localhost" port))]
+              (: conn :settimeout 0.01)
+              (send {:op :clone} conn)
+              conn))
+
+(while (not session)
+  (receive conn))
+
+(io.write prompt)
+
+((fn repl []
+   ;; this is not good; we should use non-blocking read here, but that's Hard
+   (let [input (io.read)]
+     (when (not input) (os.exit 0))
+     (send {:op :eval :code input} conn)
+     (while (< 0 (count active-requests))
+       (receive conn))
+     (io.write prompt)
+     (repl))))