diff --git a/lib/fennel b/lib/fennel
index 36fea57..1856155 100755
--- a/lib/fennel
+++ b/lib/fennel
@@ -162,14 +162,18 @@ package.preload["fennelview"] = package.preload["fennelview"] or function(...)
return ((type(k) == "number") and (1 <= k) and (k <= len) and (math.floor(k) == k))
end
local type_order = {["function"] = 5, boolean = 2, number = 1, string = 3, table = 4, thread = 7, userdata = 6}
- local function sort_keys(a, b)
+ local function sort_keys(_0_0, _1_0)
+ local _1_ = _0_0
+ local a = _1_[1]
+ local _2_ = _1_0
+ local b = _2_[1]
local ta = type(a)
local tb = type(b)
if ((ta == tb) and ((ta == "string") or (ta == "number"))) then
return (a < b)
else
- local dta = type_order[a]
- local dtb = type_order[b]
+ local dta = type_order[ta]
+ local dtb = type_order[tb]
if (dta and dtb) then
return (dta < dtb)
elseif dta then
@@ -182,7 +186,7 @@ package.preload["fennelview"] = package.preload["fennelview"] or function(...)
end
end
local function get_sequence_length(t)
- local len = 1
+ local len = 0
for i in ipairs(t) do
len = i
end
@@ -191,9 +195,9 @@ package.preload["fennelview"] = package.preload["fennelview"] or function(...)
local function get_nonsequential_keys(t)
local keys = {}
local sequence_length = get_sequence_length(t)
- for k in pairs(t) do
+ for k, v in pairs(t) do
if not sequence_key_3f(k, sequence_length) then
- table.insert(keys, k)
+ table.insert(keys, {k, v})
end
end
table.sort(keys, sort_keys)
@@ -239,12 +243,12 @@ package.preload["fennelview"] = package.preload["fennelview"] or function(...)
local function put_sequential_table(self, t, len)
puts(self, "[")
self.level = (self.level + 1)
- for i = 1, len do
- local _0_ = (1 + len)
- if ((1 < i) and (i < _0_)) then
+ for k, v in ipairs(t) do
+ local _2_ = (1 + len)
+ if ((1 < k) and (k < _2_)) then
puts(self, " ")
end
- put_value(self, t[i])
+ put_value(self, v)
end
self.level = (self.level - 1)
return puts(self, "]")
@@ -259,13 +263,16 @@ package.preload["fennelview"] = package.preload["fennelview"] or function(...)
local function put_kv_table(self, t, ordered_keys)
puts(self, "{")
self.level = (self.level + 1)
- for i, k in ipairs(ordered_keys) do
+ for i, _2_0 in ipairs(ordered_keys) do
+ local _3_ = _2_0
+ local k = _3_[1]
+ local v = _3_[2]
if (self["table-edges"] or (i ~= 1)) then
tabify(self)
end
put_key(self, k)
puts(self, " ")
- put_value(self, t[k])
+ put_value(self, v)
end
for i, v in ipairs(t) do
tabify(self)
@@ -281,20 +288,20 @@ package.preload["fennelview"] = package.preload["fennelview"] or function(...)
end
local function put_table(self, t)
local metamethod = nil
- local function _1_()
- local _0_0 = t
- if _0_0 then
- local _2_0 = getmetatable(_0_0)
- if _2_0 then
- return _2_0.__fennelview
+ local function _3_()
+ local _2_0 = t
+ if _2_0 then
+ local _4_0 = getmetatable(_2_0)
+ if _4_0 then
+ return _4_0.__fennelview
else
- return _2_0
+ return _4_0
end
else
- return _0_0
+ return _2_0
end
end
- metamethod = (self["metamethod?"] and _1_())
+ metamethod = (self["metamethod?"] and _3_())
if (already_visited_3f(self, t) and self["detect-cycles?"]) then
return puts(self, "#
")
elseif (self.level >= self.depth) then
@@ -308,14 +315,14 @@ package.preload["fennelview"] = package.preload["fennelview"] or function(...)
puts(self, "@", id)
end
if ((#non_seq_keys == 0) and (#t == 0)) then
- local function _3_()
+ local function _5_()
if self["empty-as-square"] then
return "[]"
else
return "{}"
end
end
- return puts(self, _3_())
+ return puts(self, _5_())
elseif (#non_seq_keys == 0) then
return put_sequential_table(self, t, len)
elseif "else" then
@@ -323,19 +330,30 @@ package.preload["fennelview"] = package.preload["fennelview"] or function(...)
end
end
end
- local function _0_(self, v)
+ local function _2_(self, v)
local tv = type(v)
if (tv == "string") then
return puts(self, view_quote(escape(v)))
elseif ((tv == "number") or (tv == "boolean") or (tv == "nil")) then
return puts(self, tostring(v))
- elseif (tv == "table") then
- return put_table(self, v)
- elseif "else" then
- return puts(self, "#<", tostring(v), ">")
+ else
+ local _4_
+ do
+ local _3_0 = getmetatable(v)
+ if _3_0 then
+ _4_ = _3_0.__fennelview
+ else
+ _4_ = _3_0
+ end
+ end
+ if ((tv == "table") or ((tv == "userdata") and (nil ~= _4_))) then
+ return put_table(self, v)
+ elseif "else" then
+ return puts(self, "#<", tostring(v), ">")
+ end
end
end
- put_value = _0_
+ put_value = _2_
local function one_line(str)
local ret = str:gsub("\n", " "):gsub("%[ ", "["):gsub(" %]", "]"):gsub("%{ ", "{"):gsub(" %}", "}"):gsub("%( ", "("):gsub(" %)", ")")
return ret
@@ -343,17 +361,17 @@ package.preload["fennelview"] = package.preload["fennelview"] or function(...)
local function fennelview(x, options)
local options0 = (options or {})
local inspector = nil
- local function _1_(_241)
+ local function _3_(_241)
return fennelview(_241, options0)
end
- local function _2_()
+ local function _4_()
if options0["one-line"] then
return ""
else
return " "
end
end
- inspector = {["detect-cycles?"] = not (false == options0["detect-cycles?"]), ["empty-as-square"] = options0["empty-as-square"], ["max-ids"] = {}, ["metamethod?"] = not (false == options0["metamethod?"]), ["table-edges"] = (options0["table-edges"] ~= false), appearances = count_table_appearances(x, {}), buffer = {}, depth = (options0.depth or 128), fennelview = _1_, ids = {}, indent = (options0.indent or _2_()), level = 0}
+ inspector = {["detect-cycles?"] = not (false == options0["detect-cycles?"]), ["empty-as-square"] = options0["empty-as-square"], ["max-ids"] = {}, ["metamethod?"] = not (false == options0["metamethod?"]), ["table-edges"] = (options0["table-edges"] ~= false), appearances = count_table_appearances(x, {}), buffer = {}, depth = (options0.depth or 128), fennelview = _3_, ids = {}, indent = (options0.indent or _4_()), level = 0}
put_value(inspector, x)
local str = table.concat(inspector.buffer)
if options0["one-line"] then
@@ -417,6 +435,82 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
end
return table.concat(spliced_source, "\n")
end
+ local commands = {}
+ local function command_3f(input)
+ return input:match("^%s*,")
+ end
+ commands.help = function(_, _0, on_values)
+ return on_values({"Welcome to Fennel.\nThis is the REPL where you can enter code to be evaluated.\nYou can also run these repl commands:\n\n ,help - show this message\n ,reload module-name - reload the specified module\n ,reset - erase all repl-local scope\n ,exit - leave the repl\n\nUse (doc something) to see descriptions for individual macros and special forms.\n\nFor more information about the language, see https://fennel-lang.org/reference"})
+ end
+ local function reload(module_name, env, on_values, on_error)
+ local _0_0, _1_0 = pcall(specials["load-code"]("return require(...)", env), module_name)
+ if ((_0_0 == true) and (nil ~= _1_0)) then
+ local old = _1_0
+ local _ = nil
+ package.loaded[module_name] = nil
+ _ = nil
+ local ok, new = pcall(require, module_name)
+ local new0 = nil
+ if not ok then
+ on_values(new)
+ new0 = old
+ else
+ new0 = new
+ end
+ if ((type(old) == "table") and (type(new0) == "table")) then
+ for k, v in pairs(new0) do
+ old[k] = v
+ end
+ for k in pairs(old) do
+ if (nil == new0[k]) then
+ old[k] = nil
+ end
+ end
+ package.loaded[module_name] = old
+ end
+ return on_values({"ok"})
+ elseif ((_0_0 == false) and (nil ~= _1_0)) then
+ local msg = _1_0
+ local function _3_()
+ local _2_0 = msg:gsub("\n.*", "")
+ return _2_0
+ end
+ return on_error("Runtime", _3_())
+ end
+ end
+ commands.reload = function(read, env, on_values, on_error)
+ local _0_0, _1_0, _2_0 = pcall(read)
+ if ((_0_0 == true) and (_1_0 == true) and (nil ~= _2_0)) then
+ local module_sym = _2_0
+ return reload(tostring(module_sym), env, on_values, on_error)
+ elseif ((_0_0 == false) and true and true) then
+ local _3fparse_ok = _1_0
+ local _3fmsg = _2_0
+ return on_error("Parse", (_3fmsg or _3fparse_ok))
+ end
+ end
+ commands.reset = function(_, env, on_values)
+ env.___replLocals___ = {}
+ return on_values({"ok"})
+ end
+ local function run_command(input, read, loop, env, on_values, on_error)
+ local command_name = input:match(",([^%s/]+)")
+ do
+ local _0_0 = commands[command_name]
+ if (nil ~= _0_0) then
+ local command = _0_0
+ command(read, env, on_values, on_error)
+ else
+ local _ = _0_0
+ if ("exit" ~= command_name) then
+ on_values({"Unknown command", command_name})
+ end
+ end
+ end
+ if ("exit" ~= command_name) then
+ return loop()
+ end
+ end
local function completer(env, scope, text)
local matches = {}
local input_fragment = text:gsub(".*[%s)(]+", "")
@@ -487,7 +581,7 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
local read, reset = nil, nil
local function _1_(parser_state)
local c = byte_stream(parser_state)
- chars[(#chars + 1)] = c
+ table.insert(chars, c)
return c
end
read, reset = parser.parser(_1_)
@@ -502,6 +596,15 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
end
opts.registerCompleter(_3_)
end
+ local function print_values(...)
+ local vals = {...}
+ local out = {}
+ env._, env.__ = vals[1], vals
+ for i = 1, select("#", ...) do
+ table.insert(out, pp(vals[i]))
+ end
+ return on_values(out)
+ end
local function loop()
for k in pairs(chars) do
chars[k] = nil
@@ -514,6 +617,8 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
clear_stream()
reset()
return loop()
+ elseif command_3f(src_string) then
+ return run_command(src_string, read, loop, env, on_values, on_error)
else
if parse_ok_3f then
do
@@ -523,32 +628,28 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
clear_stream()
on_error("Compile", msg)
elseif ((_4_0 == true) and (nil ~= _5_0)) then
- local source = _5_0
- local source0 = nil
+ local src = _5_0
+ local src0 = nil
if save_locals_3f then
- source0 = splice_save_locals(env, source)
+ src0 = splice_save_locals(env, src)
else
- source0 = source
+ src0 = src
end
- local lua_ok_3f, loader = pcall(specials["load-code"], source0, env)
- if not lua_ok_3f then
+ local _7_0, _8_0 = pcall(specials["load-code"], src0, env)
+ if ((_7_0 == false) and (nil ~= _8_0)) then
+ local msg = _8_0
clear_stream()
- on_error("Lua Compile", loader, source0)
- else
- local _7_0, _8_0 = nil, nil
+ on_error("Lua Compile", msg, src0)
+ elseif (true and (nil ~= _8_0)) then
+ local _0 = _7_0
+ local chunk = _8_0
local function _9_()
- return {loader()}
+ return print_values(chunk())
end
local function _10_(...)
return on_error("Runtime", ...)
end
- _7_0, _8_0 = xpcall(_9_, _10_)
- if ((_7_0 == true) and (nil ~= _8_0)) then
- local ret = _8_0
- env._ = ret[1]
- env.__ = ret
- on_values(utils.map(ret, pp))
- end
+ xpcall(_9_, _10_)
end
end
end
@@ -671,7 +772,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
return compile_body(opts.target, opts.tail)
elseif opts.nval then
local syms = {}
- for i = 1, opts.nval, 1 do
+ for i = 1, opts.nval do
local s = ((pre_syms and pre_syms[i]) or compiler.gensym(scope))
syms[i] = s
retexprs[i] = utils.expr(s, "sym")
@@ -699,10 +800,10 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
local exprs = {}
for i = 2, len do
local subexprs = compiler.compile1(ast[i], scope, parent, {nval = ((i ~= len) and 1)})
- exprs[(#exprs + 1)] = subexprs[1]
+ table.insert(exprs, subexprs[1])
if (i == len) then
- for j = 2, #subexprs, 1 do
- exprs[(#exprs + 1)] = subexprs[j]
+ for j = 2, #subexprs do
+ table.insert(exprs, subexprs[j])
end
end
end
@@ -765,7 +866,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
elseif utils["table?"](arg) then
local raw = utils.sym(compiler.gensym(scope))
local declared = compiler["declare-local"](raw, {}, f_scope, ast)
- compiler.destructure(arg, raw, ast, f_scope, f_chunk, {declaration = true, nomulti = true})
+ compiler.destructure(arg, raw, ast, f_scope, f_chunk, {declaration = true, nomulti = true, symtype = "arg"})
return declared
else
return compiler.assert(false, ("expected symbol for function parameter: %s"):format(tostring(arg)), ast[2])
@@ -779,14 +880,16 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
else
index0, docstring = index, nil
end
- for i = (index0 + 1), #ast, 1 do
+ for i = (index0 + 1), #ast do
compiler.compile1(ast[i], f_scope, f_chunk, {nval = (((i ~= #ast) and 0) or nil), tail = (i == #ast)})
end
+ local _2_
if local_fn_3f then
- compiler.emit(parent, ("local function %s(%s)"):format(fn_name, table.concat(arg_name_list, ", ")), ast)
+ _2_ = "local function %s(%s)"
else
- compiler.emit(parent, ("%s = function(%s)"):format(fn_name, table.concat(arg_name_list, ", ")), ast)
+ _2_ = "%s = function(%s)"
end
+ compiler.emit(parent, string.format(_2_, fn_name, table.concat(arg_name_list, ", ")), ast)
compiler.emit(parent, f_chunk, ast)
compiler.emit(parent, "end", ast)
set_fn_metadata(arg_list, docstring, parent, fn_name)
@@ -810,7 +913,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
local target = utils.deref(ast[2])
local special_or_macro = (scope.specials[target] or scope.macros[target])
if special_or_macro then
- return ("print([[%s]])"):format(doc_2a(special_or_macro, target))
+ return ("print(%q)"):format(doc_2a(special_or_macro, target))
else
local value = tostring(compiler.compile1(ast[2], scope, parent, {nval = 1})[1])
return ("print(require('%s').doc(%s, '%s'))"):format((utils.root.options.moduleName or "fennel"), value, tostring(ast[2]))
@@ -820,25 +923,26 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
local function dot(ast, scope, parent)
compiler.assert((1 < #ast), "expected table argument", ast)
local len = #ast
- local lhs = compiler.compile1(ast[2], scope, parent, {nval = 1})
+ local _0_ = compiler.compile1(ast[2], scope, parent, {nval = 1})
+ local lhs = _0_[1]
if (len == 2) then
- return tostring(lhs[1])
+ return tostring(lhs)
else
local indices = {}
- for i = 3, len, 1 do
+ for i = 3, len do
local index = ast[i]
if ((type(index) == "string") and utils["valid-lua-identifier?"](index)) then
table.insert(indices, ("." .. index))
else
- local _0_ = compiler.compile1(index, scope, parent, {nval = 1})
- local index0 = _0_[1]
+ local _1_ = compiler.compile1(index, scope, parent, {nval = 1})
+ local index0 = _1_[1]
table.insert(indices, ("[" .. tostring(index0) .. "]"))
end
end
- if utils["table?"](ast[2]) then
- return ("(" .. tostring(lhs[1]) .. ")" .. table.concat(indices))
+ if (tostring(lhs):find("{") or ("nil" == tostring(lhs))) then
+ return ("(" .. tostring(lhs) .. ")" .. table.concat(indices))
else
- return (tostring(lhs[1]) .. table.concat(indices))
+ return (tostring(lhs) .. table.concat(indices))
end
end
end
@@ -846,32 +950,32 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
doc_special(".", {"tbl", "key1", "..."}, "Look up key1 in tbl table. If more args are provided, do a nested lookup.")
SPECIALS.global = function(ast, scope, parent)
compiler.assert((#ast == 3), "expected name and value", ast)
- compiler.destructure(ast[2], ast[3], ast, scope, parent, {forceglobal = true, nomulti = true})
+ compiler.destructure(ast[2], ast[3], ast, scope, parent, {forceglobal = true, nomulti = true, symtype = "global"})
return nil
end
doc_special("global", {"name", "val"}, "Set name as a global with val.")
SPECIALS.set = function(ast, scope, parent)
compiler.assert((#ast == 3), "expected name and value", ast)
- compiler.destructure(ast[2], ast[3], ast, scope, parent, {noundef = true})
+ compiler.destructure(ast[2], ast[3], ast, scope, parent, {noundef = true, symtype = "set"})
return nil
end
doc_special("set", {"name", "val"}, "Set a local variable to a new value. Only works on locals using var.")
local function set_forcibly_21_2a(ast, scope, parent)
compiler.assert((#ast == 3), "expected name and value", ast)
- compiler.destructure(ast[2], ast[3], ast, scope, parent, {forceset = true})
+ compiler.destructure(ast[2], ast[3], ast, scope, parent, {forceset = true, symtype = "set"})
return nil
end
SPECIALS["set-forcibly!"] = set_forcibly_21_2a
local function local_2a(ast, scope, parent)
compiler.assert((#ast == 3), "expected name and value", ast)
- compiler.destructure(ast[2], ast[3], ast, scope, parent, {declaration = true, nomulti = true})
+ compiler.destructure(ast[2], ast[3], ast, scope, parent, {declaration = true, nomulti = true, symtype = "local"})
return nil
end
SPECIALS["local"] = local_2a
doc_special("local", {"name", "val"}, "Introduce new top-level immutable local.")
SPECIALS.var = function(ast, scope, parent)
compiler.assert((#ast == 3), "expected name and value", ast)
- compiler.destructure(ast[2], ast[3], ast, scope, parent, {declaration = true, isvar = true, nomulti = true})
+ compiler.destructure(ast[2], ast[3], ast, scope, parent, {declaration = true, isvar = true, nomulti = true, symtype = "var"})
return nil
end
doc_special("var", {"name", "val"}, "Introduce new mutable local.")
@@ -881,13 +985,13 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
compiler.assert((utils["list?"](bindings) or utils["table?"](bindings)), "expected binding table", ast)
compiler.assert(((#bindings % 2) == 0), "expected even number of name/value bindings", ast[2])
compiler.assert((#ast >= 3), "expected body expression", ast[1])
- for _ = 1, (opts.nval or 0), 1 do
+ for _ = 1, (opts.nval or 0) do
table.insert(pre_syms, compiler.gensym(scope))
end
local sub_scope = compiler["make-scope"](scope)
local sub_chunk = {}
for i = 1, #bindings, 2 do
- compiler.destructure(bindings[i], bindings[(i + 1)], ast, sub_scope, sub_chunk, {declaration = true, nomulti = true})
+ compiler.destructure(bindings[i], bindings[(i + 1)], ast, sub_scope, sub_chunk, {declaration = true, nomulti = true, symtype = "let"})
end
return SPECIALS["do"](ast, scope, parent, opts, 3, sub_chunk, sub_scope, pre_syms)
end
@@ -896,9 +1000,10 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
compiler.assert((#ast > 3), "expected table, key, and value arguments", ast)
local root = compiler.compile1(ast[2], scope, parent, {nval = 1})[1]
local keys = {}
- for i = 3, (#ast - 1), 1 do
- local key = compiler.compile1(ast[i], scope, parent, {nval = 1})[1]
- keys[(#keys + 1)] = tostring(key)
+ for i = 3, (#ast - 1) do
+ local _0_ = compiler.compile1(ast[i], scope, parent, {nval = 1})
+ local key = _0_[1]
+ table.insert(keys, tostring(key))
end
local value = compiler.compile1(ast[#ast], scope, parent, {nval = 1})[1]
local rootstr = tostring(root)
@@ -917,7 +1022,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
elseif (opts.nval and (opts.nval ~= 0) and not opts.target) then
local accum = {}
local target_exprs = {}
- for i = 1, opts.nval, 1 do
+ for i = 1, opts.nval do
local s = compiler.gensym(scope)
accum[i] = s
target_exprs[i] = utils.expr(s, "sym")
@@ -1001,13 +1106,13 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
compiler.emit(parent, "end", ast)
return utils.expr(("%s(%s)"):format(tostring(s), iifeargs), "statement")
elseif (wrapper == "none") then
- for i = 1, #buffer, 1 do
+ for i = 1, #buffer do
compiler.emit(parent, buffer[i], ast)
end
return {returned = true}
else
compiler.emit(parent, ("local %s"):format(inner_target), ast)
- for i = 1, #buffer, 1 do
+ for i = 1, #buffer do
compiler.emit(parent, buffer[i], ast)
end
return target_exprs
@@ -1037,7 +1142,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
local chunk = {}
compiler.emit(parent, ("for %s in %s do"):format(table.concat(bind_vars, ", "), table.concat(val_names, ", ")), ast)
for raw, args in utils.stablepairs(destructures) do
- compiler.destructure(args, raw, ast, sub_scope, chunk, {declaration = true, nomulti = true})
+ compiler.destructure(args, raw, ast, sub_scope, chunk, {declaration = true, nomulti = true, symtype = "each"})
end
compiler["apply-manglings"](sub_scope, new_manglings, ast)
compile_do(ast, sub_scope, chunk, 3)
@@ -1051,8 +1156,8 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
local len2 = #parent
local sub_chunk = {}
if (len1 ~= len2) then
- for i = (len1 + 1), len2, 1 do
- sub_chunk[(#sub_chunk + 1)] = parent[i]
+ for i = (len1 + 1), len2 do
+ table.insert(sub_chunk, parent[i])
parent[i] = nil
end
compiler.emit(parent, "while true do", ast)
@@ -1074,7 +1179,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
local chunk = {}
compiler.assert(utils["sym?"](binding_sym), ("unable to bind %s %s"):format(type(binding_sym), tostring(binding_sym)), ast[2])
compiler.assert((#ast >= 3), "expected body expression", ast[1])
- for i = 1, math.min(#ranges, 3), 1 do
+ for i = 1, math.min(#ranges, 3) do
range_args[i] = tostring(compiler.compile1(ranges[i], sub_scope, parent, {nval = 1})[1])
end
compiler.emit(parent, ("for %s = %s do"):format(compiler["declare-local"](binding_sym, {}, sub_scope, ast), table.concat(range_args, ", ")), ast)
@@ -1084,7 +1189,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
end
SPECIALS["for"] = for_2a
doc_special("for", {"[index start stop step?]", "..."}, "Numeric loop construct.\nEvaluates body once for each value between start and stop (inclusive).")
- local function native_method_call(ast, scope, parent, target, args)
+ local function native_method_call(ast, _scope, _parent, target, args)
local _0_ = ast
local _ = _0_[1]
local _0 = _0_[2]
@@ -1136,8 +1241,12 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
doc_special(":", {"tbl", "method-name", "..."}, "Call the named method on tbl with the provided args.\nMethod name doesn't have to be known at compile-time; if it is, use\n(tbl:method-name ...) instead.")
SPECIALS.comment = function(ast, _, parent)
local els = {}
- for i = 2, #ast, 1 do
- els[(#els + 1)] = tostring(ast[i]):gsub("\n", " ")
+ for i = 2, #ast do
+ local function _1_()
+ local _0_0 = tostring(ast[i]):gsub("\n", " ")
+ return _0_0
+ end
+ table.insert(els, _1_())
end
return compiler.emit(parent, ("-- " .. table.concat(els, " ")), ast)
end
@@ -1209,10 +1318,10 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
return utils.expr(zero_arity, "literal")
else
local operands = {}
- for i = 2, len, 1 do
+ for i = 2, len do
local subexprs = nil
local _1_
- if (i == 1) then
+ if (i ~= len) then
_1_ = 1
else
_1_ = nil
@@ -1335,7 +1444,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
doc_special("quote", {"x"}, "Quasiquote the following form. Only works in macro/compiler scope.")
local already_warned_3f = {}
local compile_env_warning = ("WARNING: Attempting to %s %s in compile" .. " scope.\nIn future versions of Fennel this will not" .. " be allowed without the\n--no-compiler-sandbox flag" .. " or passing :compiler-env _G in options.\n")
- local function compiler_env_warn(env, key)
+ local function compiler_env_warn(_, key)
local v = _G[key]
if (v and io and io.stderr and not already_warned_3f[key]) then
already_warned_3f[key] = true
@@ -1352,8 +1461,8 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
compiler.assert(compiler.scopes.macro, "must call from macro", ast)
return compiler.scopes.macro.manglings[tostring(symbol)]
end
- local function _3_()
- return utils.sym(compiler.gensym((compiler.scopes.macro or scope)))
+ local function _3_(base)
+ return utils.sym(compiler.gensym((compiler.scopes.macro or scope), base))
end
local function _4_(form)
compiler.assert(compiler.scopes.macro, "must call from macro", ast)
@@ -1403,17 +1512,19 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
return find_in_path(1)
end
local function make_searcher(options)
- local opts = utils.copy(utils.root.options)
- for k, v in pairs((options or {})) do
- opts[k] = v
- end
local function _1_(module_name)
- local filename = search_module(module_name)
- if filename then
- local function _2_(mod_name)
- return utils["fennel-module"].dofile(filename, opts, mod_name)
+ local opts = utils.copy(utils.root.options)
+ for k, v in pairs((options or {})) do
+ opts[k] = v
+ end
+ opts["module-name"] = module_name
+ local _2_0 = search_module(module_name)
+ if (nil ~= _2_0) then
+ local filename = _2_0
+ local function _3_(...)
+ return utils["fennel-module"].dofile(filename, opts, ...)
end
- return _2_
+ return _3_, filename
end
end
return _1_
@@ -1428,7 +1539,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
local function compiler_env_domodule(modname, env, _3fast)
local filename = compiler.assert(search_module(modname), (modname .. " module not found."), _3fast)
local globals = macro_globals(env, current_global_names())
- return utils["fennel-module"].dofile(filename, {allowedGlobals = globals, env = env, scope = compiler.scopes.compiler, useMetadata = utils.root.options.useMetadata})
+ return utils["fennel-module"].dofile(filename, {allowedGlobals = globals, env = env, scope = compiler.scopes.compiler, useMetadata = utils.root.options.useMetadata}, modname, filename)
end
local macro_loaded = {}
local function metadata_only_fennel(modname)
@@ -1452,9 +1563,12 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
end
return nil
end
- SPECIALS["require-macros"] = function(ast, scope, parent)
- compiler.assert((#ast == 2), "Expected one module name argument", ast)
- local modname = ast[2]
+ SPECIALS["require-macros"] = function(ast, scope, parent, real_ast)
+ compiler.assert((#ast == 2), "Expected one module name argument", (real_ast or ast))
+ local filename = (ast[2].filename or ast.filename)
+ local modname_code = compiler.compile(ast[2])
+ local modname = load_code(modname_code, nil, filename)(utils.root.options["module-name"], filename)
+ compiler.assert((type(modname) == "string"), "module name must compile to string", (real_ast or ast))
if not macro_loaded[modname] then
local env = make_compiler_env(ast, scope, parent)
macro_loaded[modname] = compiler_env_domodule(modname, env, ast)
@@ -1462,7 +1576,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
return add_macros(macro_loaded[modname], ast, scope, parent)
end
doc_special("require-macros", {"macro-module-name"}, "Load given module and use its contents as macro definitions in current scope.\nMacro module should return a table of macro functions with string keys.\nConsider using import-macros instead as it is more flexible.")
- local function emit_fennel(src, path, opts, sub_chunk)
+ local function emit_included_fennel(src, path, opts, sub_chunk)
local subscope = compiler["make-scope"](utils.root.scope.parent)
local forms = {}
if utils.root.options.requireAsInclude then
@@ -1474,7 +1588,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
for i = 1, #forms do
local subopts = nil
if (i == #forms) then
- subopts = {nval = 1, tail = true}
+ subopts = {tail = true}
else
subopts = {nval = 0}
end
@@ -1512,7 +1626,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
table.insert(utils.root.chunk, i, v)
end
if fennel_3f then
- emit_fennel(src, path, opts, sub_chunk)
+ emit_included_fennel(src, path, opts, sub_chunk)
else
compiler.emit(sub_chunk, src, ast)
end
@@ -1562,7 +1676,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
local opts = utils.copy(utils.root.options)
opts.scope = compiler["make-scope"](compiler.scopes.compiler)
opts.allowedGlobals = macro_globals(env, current_global_names())
- return load_code(compiler.compile(ast, opts), wrap_env(env))()
+ return load_code(compiler.compile(ast, opts), wrap_env(env))(opts["module-name"], ast.filename)
end
SPECIALS.macros = function(ast, scope, parent)
compiler.assert((#ast == 2), "Expected one table argument", ast)
@@ -1659,12 +1773,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
end
local allowed_globals = nil
local function global_allowed(name)
- local found_3f = not allowed_globals
- if not allowed_globals then
- return true
- else
- return utils["member?"](name, allowed_globals)
- end
+ return (not allowed_globals or utils["member?"](name, allowed_globals))
end
local function unique_mangling(original, mangling, scope, append)
if scope.unmanglings[mangling] then
@@ -1675,7 +1784,6 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
end
local function local_mangling(str, scope, ast, temp_manglings)
assert_compile(not utils["multi-sym?"](str), ("unexpected multi symbol " .. str), ast)
- local append = 0
local raw = nil
if (utils["lua-keywords"][str] or str:match("^%d")) then
raw = ("_" .. str)
@@ -1704,7 +1812,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
end
local function combine_parts(parts, scope)
local ret = (scope.manglings[parts[1]] or global_mangling(parts[1]))
- for i = 2, #parts, 1 do
+ for i = 2, #parts do
if utils["valid-lua-identifier?"](parts[i]) then
if (parts["multi-sym-method-call"] and (i == #parts)) then
ret = (ret .. ":" .. parts[i])
@@ -1723,7 +1831,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
mangling = ((base or "") .. "_" .. append .. "_")
append = (append + 1)
end
- scope.unmanglings[mangling] = true
+ scope.unmanglings[mangling] = (base or true)
return mangling
end
local function autogensym(base, scope)
@@ -1744,6 +1852,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
end
local function check_binding_valid(symbol, scope, ast)
local name = utils.deref(symbol)
+ assert_compile(not name:find("&"), "illegal character: &", symbol)
assert_compile(not (scope.specials[name] or scope.macros[name]), ("local %s was overshadowed by a special form or macro"):format(name), ast)
return assert_compile(not utils["quoted?"](symbol), string.format("macro tried to bind %s without gensym", name), symbol)
end
@@ -1796,10 +1905,10 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
elseif ((#chunk >= 3) and (chunk[(#chunk - 2)].leaf == "do") and not chunk[(#chunk - 1)].leaf and (chunk[#chunk].leaf == "end")) then
local kid = peephole(chunk[(#chunk - 1)])
local new_chunk = {ast = chunk.ast}
- for i = 1, (#chunk - 3), 1 do
+ for i = 1, (#chunk - 3) do
table.insert(new_chunk, peephole(chunk[i]))
end
- for i = 1, #kid, 1 do
+ for i = 1, #kid do
table.insert(new_chunk, kid[i])
end
return new_chunk
@@ -1838,7 +1947,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
local code = chunk.leaf
local info = chunk.ast
if sm then
- sm[(#sm + 1)] = ((info and info.line) or ( - 1))
+ table.insert(sm, ((info and info.line) or ( - 1)))
end
return code
else
@@ -1887,7 +1996,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
local sm = {}
local ret = flatten_chunk(sm, chunk0, options.indent, 0)
if sm then
- sm.short_src = (options.filename or ret)
+ sm.short_src = make_short_src((options.filename or options.source or ret))
if options.filename then
sm.key = ("@" .. options.filename)
else
@@ -1928,7 +2037,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
end
local function keep_side_effects(exprs, chunk, start, ast)
local start0 = (start or 1)
- for j = start0, #exprs, 1 do
+ for j = start0, #exprs do
local se = exprs[j]
if ((se.type == "expression") and (se[1] ~= "nil")) then
emit(chunk, string.format("do local _ = %s end", tostring(se)), ast)
@@ -1946,11 +2055,11 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
if (n ~= len) then
if (len > n) then
keep_side_effects(exprs, parent, (n + 1), ast)
- for i = (n + 1), len, 1 do
+ for i = (n + 1), len do
exprs[i] = nil
end
else
- for i = (#exprs + 1), n, 1 do
+ for i = (#exprs + 1), n do
exprs[i] = utils.expr("nil", "literal")
end
end
@@ -2040,6 +2149,31 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
return exprs2
end
end
+ local function compile_function_call(ast, scope, parent, opts, compile1, len)
+ local fargs = {}
+ local fcallee = compile1(ast[1], scope, parent, {nval = 1})[1]
+ assert_compile((fcallee.type ~= "literal"), ("cannot call literal value " .. tostring(ast[1])), ast)
+ for i = 2, len do
+ local subexprs = nil
+ local _0_
+ if (i ~= len) then
+ _0_ = 1
+ else
+ _0_ = nil
+ end
+ subexprs = compile1(ast[i], scope, parent, {nval = _0_})
+ table.insert(fargs, (subexprs[1] or utils.expr("nil", "literal")))
+ if (i == len) then
+ for j = 2, #subexprs do
+ table.insert(fargs, subexprs[j])
+ end
+ else
+ keep_side_effects(subexprs, parent, 2, ast[i])
+ end
+ end
+ local call = string.format("%s(%s)", tostring(fcallee), exprs1(fargs))
+ return handle_compile_opts({utils.expr(call, "statement")}, parent, opts, ast)
+ end
local function compile_call(ast, scope, parent, opts, compile1)
utils.hook("call", ast, scope)
local len = #ast
@@ -2052,28 +2186,10 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
elseif (multi_sym_parts and multi_sym_parts["multi-sym-method-call"]) then
local table_with_method = table.concat({unpack(multi_sym_parts, 1, (#multi_sym_parts - 1))}, ".")
local method_to_call = multi_sym_parts[#multi_sym_parts]
- local new_ast = utils.list(utils.sym(":", scope), utils.sym(table_with_method, scope), method_to_call)
- for i = 2, len, 1 do
- new_ast[(#new_ast + 1)] = ast[i]
- end
+ local new_ast = utils.list(utils.sym(":", scope), utils.sym(table_with_method, scope), method_to_call, select(2, unpack(ast)))
return compile1(new_ast, scope, parent, opts)
else
- local fargs = {}
- local fcallee = compile1(ast[1], scope, parent, {nval = 1})[1]
- assert_compile((fcallee.type ~= "literal"), ("cannot call literal value " .. tostring(first)), ast)
- for i = 2, len, 1 do
- local subexprs = compile1(ast[i], scope, parent, {nval = (((i ~= len) and 1) or nil)})
- fargs[(#fargs + 1)] = (subexprs[1] or utils.expr("nil", "literal"))
- if (i == len) then
- for j = 2, #subexprs, 1 do
- fargs[(#fargs + 1)] = subexprs[j]
- end
- else
- keep_side_effects(subexprs, parent, 2, ast[i])
- end
- end
- local call = string.format("%s(%s)", tostring(fcallee), exprs1(fargs))
- return handle_compile_opts({utils.expr(call, "statement")}, parent, opts, ast)
+ return compile_function_call(ast, scope, parent, opts, compile1, len)
end
end
local function compile_varg(ast, scope, parent, opts)
@@ -2091,7 +2207,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
end
return handle_compile_opts({e}, parent, opts, ast)
end
- local function compile_scalar(ast, scope, parent, opts)
+ local function compile_scalar(ast, _scope, parent, opts)
local serialize = nil
do
local _0_0 = type(ast)
@@ -2114,9 +2230,9 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
end
local function compile_table(ast, scope, parent, opts, compile1)
local buffer = {}
- for i = 1, #ast, 1 do
+ for i = 1, #ast do
local nval = ((i ~= #ast) and 1)
- buffer[(#buffer + 1)] = exprs1(compile1(ast[i], scope, parent, {nval = nval}))
+ table.insert(buffer, exprs1(compile1(ast[i], scope, parent, {nval = nval})))
end
local function write_other_values(k)
if ((type(k) ~= "number") or (math.floor(k) ~= k) or (k < 1) or (k > #ast)) then
@@ -2174,6 +2290,8 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
local isvar = _0_["isvar"]
local nomulti = _0_["nomulti"]
local noundef = _0_["noundef"]
+ local symtype = _0_["symtype"]
+ local symtype0 = ("_" .. (symtype or "dst"))
local setter = nil
if declaration then
setter = "local %s = %s"
@@ -2185,7 +2303,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
local raw = symbol[1]
assert_compile(not (nomulti and utils["multi-sym?"](raw)), ("unexpected multi symbol " .. raw), up1)
if declaration then
- return declare_local(symbol, {var = isvar}, scope, symbol, new_manglings)
+ return declare_local(symbol, nil, scope, symbol, new_manglings)
else
local parts = (utils["multi-sym?"](raw) or {raw})
local meta = scope.symmeta[parts[1]]
@@ -2233,72 +2351,101 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
end
return ret
end
- local function destructure1(left, rightexprs, up1, top)
- if (utils["sym?"](left) and (left[1] ~= "nil")) then
- local lname = getname(left, up1)
- check_binding_valid(left, scope, left)
- if top then
- compile_top_target({lname})
+ local function destructure_sym(left, rightexprs, up1, top_3f)
+ local lname = getname(left, up1)
+ check_binding_valid(left, scope, left)
+ if top_3f then
+ compile_top_target({lname})
+ else
+ emit(parent, setter:format(lname, exprs1(rightexprs)), left)
+ end
+ if declaration then
+ scope.symmeta[utils.deref(left)] = {var = isvar}
+ return nil
+ end
+ end
+ local function destructure_table(left, rightexprs, top_3f, destructure1)
+ local s = gensym(scope, symtype0)
+ local right = nil
+ do
+ local _2_0 = nil
+ if top_3f then
+ _2_0 = exprs1(compile1(from, scope, parent))
else
- emit(parent, setter:format(lname, exprs1(rightexprs)), left)
+ _2_0 = exprs1(rightexprs)
end
- elseif utils["table?"](left) then
- local s = gensym(scope)
- local right = nil
- if top then
- right = exprs1(compile1(from, scope, parent))
- else
- right = exprs1(rightexprs)
- end
- if (right == "") then
+ if (_2_0 == "") then
right = "nil"
+ elseif (nil ~= _2_0) then
+ local right0 = _2_0
+ right = right0
+ else
+ right = nil
end
- emit(parent, string.format("local %s = %s", s, right), left)
- for k, v in utils.stablepairs(left) do
- if (utils["sym?"](left[k]) and (left[k][1] == "&")) then
- assert_compile(((type(k) == "number") and not left[(k + 2)]), "expected rest argument before last parameter", left)
+ end
+ emit(parent, string.format("local %s = %s", s, right), left)
+ for k, v in utils.stablepairs(left) do
+ if not (("number" == type(k)) and tostring(left[(k - 1)]):find("^&")) then
+ if (utils["sym?"](v) and (utils.deref(v) == "&")) then
local unpack_str = "{(table.unpack or unpack)(%s, %s)}"
local formatted = string.format(unpack_str, s, k)
local subexpr = utils.expr(formatted, "expression")
+ assert_compile((utils["sequence?"](left) and (nil == left[(k + 2)])), "expected rest argument before last parameter", left)
destructure1(left[(k + 1)], {subexpr}, left)
- return
+ elseif (utils["sym?"](k) and (utils.deref(k) == "&as")) then
+ destructure_sym(v, {utils.expr(tostring(s))}, left)
+ elseif (utils["sequence?"](left) and (utils.deref(v) == "&as")) then
+ local _, next_sym, trailing = select(k, unpack(left))
+ assert_compile((nil == trailing), "expected &as argument before last parameter", left)
+ destructure_sym(next_sym, {utils.expr(tostring(s))}, left)
else
- if (utils["sym?"](k) and (tostring(k) == ":") and utils["sym?"](v)) then
- k = tostring(v)
+ local key = nil
+ if (type(k) == "string") then
+ key = serialize_string(k)
+ else
+ key = k
end
- if (type(k) ~= "number") then
- k = serialize_string(k)
- end
- local subexpr = utils.expr(string.format("%s[%s]", s, k), "expression")
+ local subexpr = utils.expr(string.format("%s[%s]", s, key), "expression")
destructure1(v, {subexpr}, left)
end
end
- elseif utils["list?"](left) then
- local left_names, tables = {}, {}
- for i, name in ipairs(left) do
- local symname = nil
- if utils["sym?"](name) then
- symname = getname(name, up1)
- else
- symname = gensym(scope)
- tables[i] = {name, utils.expr(symname, "sym")}
- end
- table.insert(left_names, symname)
- end
- if top then
- compile_top_target(left_names)
+ end
+ return nil
+ end
+ local function destructure_values(left, up1, top_3f, destructure1)
+ local left_names, tables = {}, {}
+ for i, name in ipairs(left) do
+ if utils["sym?"](name) then
+ table.insert(left_names, getname(name, up1))
else
- local lvalue = table.concat(left_names, ", ")
- local setting = setter:format(lvalue, exprs1(rightexprs))
- emit(parent, setting, left)
+ local symname = gensym(scope, symtype0)
+ table.insert(left_names, symname)
+ tables[i] = {name, utils.expr(symname, "sym")}
end
- for _, pair in utils.stablepairs(tables) do
- destructure1(pair[1], {pair[2]}, left)
+ end
+ assert_compile(top_3f, "can't nest multi-value destructuring", left)
+ compile_top_target(left_names)
+ if declaration then
+ for _, sym in ipairs(left) do
+ scope.symmeta[utils.deref(sym)] = {var = isvar}
end
+ end
+ for _, pair in utils.stablepairs(tables) do
+ destructure1(pair[1], {pair[2]}, left)
+ end
+ return nil
+ end
+ local function destructure1(left, rightexprs, up1, top_3f)
+ if (utils["sym?"](left) and (left[1] ~= "nil")) then
+ destructure_sym(left, rightexprs, up1, top_3f)
+ elseif utils["table?"](left) then
+ destructure_table(left, rightexprs, top_3f, destructure1)
+ elseif utils["list?"](left) then
+ destructure_values(left, up1, top_3f, destructure1)
else
assert_compile(false, string.format("unable to bind %s %s", type(left), tostring(left)), (((type(up1[2]) == "table") and up1[2]) or up1))
end
- if top then
+ if top_3f then
return {returned = true}
end
end
@@ -2329,10 +2476,10 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
scope.specials.require = require_include
end
utils.root.chunk, utils.root.scope, utils.root.options = chunk, scope, opts
- for ok, val in parser.parser(strm, opts.filename, opts) do
- vals[(#vals + 1)] = val
+ for _, val in parser.parser(strm, opts.filename, opts) do
+ table.insert(vals, val)
end
- for i = 1, #vals, 1 do
+ for i = 1, #vals do
local exprs = compile1(vals[i], scope, chunk, {nval = (((i < #vals) and 0) or nil), tail = (i == #vals)})
keep_side_effects(exprs, chunk, nil, vals[i])
end
@@ -2512,11 +2659,7 @@ end
package.preload["fennel.friend"] = package.preload["fennel.friend"] or function(...)
local function ast_source(ast)
local m = getmetatable(ast)
- if (m and m.line and m) then
- return m
- else
- return ast
- end
+ return ((m and m.line and m) or ast or {})
end
local suggestions = {["$ and $... in hashfn are mutually exclusive"] = {"modifying the hashfn so it only contains $... or $, $1, $2, $3, etc"}, ["can't start multisym segment with a digit"] = {"removing the digit", "adding a non-digit before the digit"}, ["cannot call literal value"] = {"checking for typos", "checking for a missing function name"}, ["could not compile value of type "] = {"debugging the macro you're calling not to return a coroutine or userdata"}, ["could not read number (.*)"] = {"removing the non-digit character", "beginning the identifier with a non-digit if it is not meant to be a number"}, ["expected a function.* to call"] = {"removing the empty parentheses", "using square brackets if you want an empty table"}, ["expected binding table"] = {"placing a table here in square brackets containing identifiers to bind"}, ["expected body expression"] = {"putting some code in the body of this form after the bindings"}, ["expected each macro to be function"] = {"ensuring that the value for each key in your macros table contains a function", "avoid defining nested macro tables"}, ["expected even number of name/value bindings"] = {"finding where the identifier or value is missing"}, ["expected even number of values in table literal"] = {"removing a key", "adding a value"}, ["expected local"] = {"looking for a typo", "looking for a local which is used out of its scope"}, ["expected macros to be table"] = {"ensuring your macro definitions return a table"}, ["expected parameters"] = {"adding function parameters as a list of identifiers in brackets"}, ["expected rest argument before last parameter"] = {"moving & to right before the final identifier when destructuring"}, ["expected symbol for function parameter: (.*)"] = {"changing %s to an identifier instead of a literal value"}, ["expected var (.*)"] = {"declaring %s using var instead of let/local", "introducing a new local instead of changing the value of %s"}, ["expected vararg as last parameter"] = {"moving the \"...\" to the end of the parameter list"}, ["expected whitespace before opening delimiter"] = {"adding whitespace"}, ["global (.*) conflicts with local"] = {"renaming local %s"}, ["illegal character: (.)"] = {"deleting or replacing %s", "avoiding reserved characters like \", \\, ', ~, ;, @, `, and comma"}, ["local (.*) was overshadowed by a special form or macro"] = {"renaming local %s"}, ["macro not found in macro module"] = {"checking the keys of the imported macro module's returned table"}, ["macro tried to bind (.*) without gensym"] = {"changing to %s# when introducing identifiers inside macros"}, ["malformed multisym"] = {"ensuring each period or colon is not followed by another period or colon"}, ["may only be used at compile time"] = {"moving this to inside a macro if you need to manipulate symbols/lists", "using square brackets instead of parens to construct a table"}, ["method must be last component"] = {"using a period instead of a colon for field access", "removing segments after the colon", "making the method call, then looking up the field on the result"}, ["mismatched closing delimiter (.), expected (.)"] = {"replacing %s with %s", "deleting %s", "adding matching opening delimiter earlier"}, ["multisym method calls may only be in call position"] = {"using a period instead of a colon to reference a table's fields", "putting parens around this"}, ["unable to bind (.*)"] = {"replacing the %s with an identifier"}, ["unexpected closing delimiter (.)"] = {"deleting %s", "adding matching opening delimiter earlier"}, ["unexpected multi symbol (.*)"] = {"removing periods or colons from %s"}, ["unexpected vararg"] = {"putting \"...\" at the end of the fn parameters if the vararg was intended"}, ["unknown global in strict mode: (.*)"] = {"looking to see if there's a typo", "using the _G table instead, eg. _G.%s if you really want a global", "moving this code to somewhere that %s is in scope", "binding %s as a local in the scope of this code"}, ["unused local (.*)"] = {"fixing a typo so %s is used", "renaming the local to _%s"}, ["use of global (.*) is aliased by a local"] = {"renaming local %s", "refer to the global using _G.%s instead of directly"}}
local unpack = (_G.unpack or table.unpack)
@@ -2575,7 +2718,7 @@ package.preload["fennel.friend"] = package.preload["fennel.friend"] or function(
local bytestart = _1_["bytestart"]
local filename = _1_["filename"]
local line = _1_["line"]
- local ok, codeline, bol, eol = pcall(read_line, filename, line, source)
+ local ok, codeline, bol = pcall(read_line, filename, line, source)
local suggestions0 = suggest(msg)
local out = {msg, ""}
if (ok and codeline) then
@@ -2622,13 +2765,22 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(
index = (index + 1)
return b
else
- c = getchunk(parser_state)
- if (not c or (c == "")) then
+ local _1_0, _2_0, _3_0 = getchunk(parser_state)
+ local _4_
+ do
+ local char = _1_0
+ _4_ = ((nil ~= _1_0) and (char ~= ""))
+ end
+ if _4_ then
+ local char = _1_0
+ c = char
+ index = 2
+ return c:byte()
+ else
+ local _ = _1_0
done_3f = true
return nil
end
- index = 2
- return c:byte(1)
end
end
end
@@ -2639,7 +2791,7 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(
return _0_, _1_
end
local function string_stream(str)
- local str0 = str:gsub("^#![^\n]*\n", "")
+ local str0 = str:gsub("^#!", ";;")
local index = 1
local function _0_()
local r = str0:byte(index)
@@ -2682,198 +2834,241 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(
end
return r
end
- local function parse_error(msg)
- local _0_ = (utils.root.options or {})
+ local function parse_error(msg, byteindex_override)
+ local _0_ = (options or utils.root.options or {})
local source = _0_["source"]
local unfriendly = _0_["unfriendly"]
utils.root.reset()
if unfriendly then
return error(string.format("Parse error in %s:%s: %s", (filename or "unknown"), (line or "?"), msg), 0)
else
- return friend["parse-error"](msg, (filename or "unknown"), (line or "?"), byteindex, source)
+ return friend["parse-error"](msg, (filename or "unknown"), (line or "?"), (byteindex_override or byteindex), source)
end
end
local function parse_stream()
local whitespace_since_dispatch, done_3f, retval = true
local function dispatch(v)
- if (#stack == 0) then
+ local _0_0 = stack[#stack]
+ if (_0_0 == nil) then
retval, done_3f, whitespace_since_dispatch = v, true, false
return nil
- elseif stack[#stack].prefix then
- local stacktop = stack[#stack]
- stack[#stack] = nil
- return dispatch(utils.list(utils.sym(stacktop.prefix), v))
- else
+ elseif ((type(_0_0) == "table") and (nil ~= _0_0.prefix)) then
+ local prefix = _0_0.prefix
+ table.remove(stack)
+ return dispatch(utils.list(utils.sym(prefix), v))
+ elseif (nil ~= _0_0) then
+ local top = _0_0
whitespace_since_dispatch = false
- return table.insert(stack[#stack], v)
+ return table.insert(top, v)
end
end
local function badend()
local accum = utils.map(stack, "closer")
- return parse_error(string.format("expected closing delimiter%s %s", (((#stack == 1) and "") or "s"), string.char(unpack(accum))))
+ local _0_
+ if (#stack == 1) then
+ _0_ = ""
+ else
+ _0_ = "s"
+ end
+ return parse_error(string.format("expected closing delimiter%s %s", _0_, string.char(unpack(accum))))
end
- while true do
- local b = nil
- while true do
- b = getb()
- if (b and whitespace_3f(b)) then
- whitespace_since_dispatch = true
- end
- if (not b or not whitespace_3f(b)) then
- break
- end
+ local function skip_whitespace(b)
+ if (b and whitespace_3f(b)) then
+ whitespace_since_dispatch = true
+ return skip_whitespace(getb())
+ elseif (not b and (#stack > 0)) then
+ return badend()
+ else
+ return b
end
- if not b then
- if (#stack > 0) then
- badend()
- end
- return nil
+ end
+ local function skip_comment(b)
+ if (b and (10 ~= b)) then
+ return skip_comment(getb())
+ else
+ return b
end
- if (b == 59) then
- while true do
- b = getb()
- if (not b or (b == 10)) then
- break
- end
+ end
+ local function open_table(b)
+ if not whitespace_since_dispatch then
+ parse_error(("expected whitespace before opening delimiter " .. string.char(b)))
+ end
+ return table.insert(stack, {bytestart = byteindex, closer = delims[b], filename = filename, line = line})
+ end
+ local function close_list(list)
+ return dispatch(setmetatable(list, getmetatable(utils.list())))
+ end
+ local function close_sequence(tbl)
+ local val = utils.sequence(unpack(tbl))
+ for k, v in pairs(tbl) do
+ getmetatable(val)[k] = v
+ end
+ return dispatch(val)
+ end
+ local function close_curly_table(tbl)
+ local val = {}
+ if ((#tbl % 2) ~= 0) then
+ byteindex = (byteindex - 1)
+ parse_error("expected even number of values in table literal")
+ end
+ setmetatable(val, tbl)
+ for i = 1, #tbl, 2 do
+ if ((tostring(tbl[i]) == ":") and utils["sym?"](tbl[(i + 1)]) and utils["sym?"](tbl[i])) then
+ tbl[i] = tostring(tbl[(i + 1)])
end
- elseif (type(delims[b]) == "number") then
- if not whitespace_since_dispatch then
- parse_error(("expected whitespace before opening delimiter " .. string.char(b)))
- end
- table.insert(stack, setmetatable({bytestart = byteindex, closer = delims[b], filename = filename, line = line}, getmetatable(utils.list())))
- elseif delims[b] then
- local last = stack[#stack]
- if (#stack == 0) then
- parse_error(("unexpected closing delimiter " .. string.char(b)))
- end
- local val = nil
- if (last.closer ~= b) then
- parse_error(("mismatched closing delimiter " .. string.char(b) .. ", expected " .. string.char(last.closer)))
- end
- last.byteend = byteindex
- if (b == 41) then
- val = last
- elseif (b == 93) then
- val = utils.sequence(unpack(last))
- for k, v in pairs(last) do
- getmetatable(val)[k] = v
- end
+ val[tbl[i]] = tbl[(i + 1)]
+ end
+ return dispatch(val)
+ end
+ local function close_table(b)
+ local top = table.remove(stack)
+ if (top == nil) then
+ parse_error(("unexpected closing delimiter " .. string.char(b)))
+ end
+ if (top.closer ~= b) then
+ parse_error(("mismatched closing delimiter " .. string.char(b) .. ", expected " .. string.char(top.closer)))
+ end
+ top.byteend = byteindex
+ if (b == 41) then
+ return close_list(top)
+ elseif (b == 93) then
+ return close_sequence(top)
+ else
+ return close_curly_table(top)
+ end
+ end
+ local function parse_string_loop(chars, b, state)
+ table.insert(chars, b)
+ local state0 = nil
+ do
+ local _0_0 = {state, b}
+ if ((type(_0_0) == "table") and (_0_0[1] == "base") and (_0_0[2] == 92)) then
+ state0 = "backslash"
+ elseif ((type(_0_0) == "table") and (_0_0[1] == "base") and (_0_0[2] == 34)) then
+ state0 = "done"
else
- if ((#last % 2) ~= 0) then
- byteindex = (byteindex - 1)
- parse_error("expected even number of values in table literal")
- end
- val = {}
- setmetatable(val, last)
- for i = 1, #last, 2 do
- if ((tostring(last[i]) == ":") and utils["sym?"](last[(i + 1)]) and utils["sym?"](last[i])) then
- last[i] = tostring(last[(i + 1)])
- end
- val[last[i]] = last[(i + 1)]
- end
+ local _ = _0_0
+ state0 = "base"
end
- stack[#stack] = nil
- dispatch(val)
- elseif (b == 34) then
- local chars = {34}
- local state = "base"
- stack[(#stack + 1)] = {closer = 34}
- while true do
- b = getb()
- chars[(#chars + 1)] = b
- if (state == "base") then
- if (b == 92) then
- state = "backslash"
- elseif (b == 34) then
- state = "done"
- end
- else
- state = "base"
- end
- if (not b or (state == "done")) then
- break
- end
- end
- if not b then
- badend()
- end
- stack[#stack] = nil
- local raw = string.char(unpack(chars))
- local formatted = nil
- local function _2_(c)
- return ("\\" .. c:byte())
- end
- formatted = raw:gsub("[\1-\31]", _2_)
- local load_fn = (_G.loadstring or load)(string.format("return %s", formatted))
- dispatch(load_fn())
- elseif prefixes[b] then
- table.insert(stack, {prefix = prefixes[b]})
- local nextb = getb()
- if whitespace_3f(nextb) then
- if (b ~= 35) then
- parse_error("invalid whitespace after quoting prefix")
- end
- stack[#stack] = nil
- dispatch(utils.sym("#"))
- end
- ungetb(nextb)
- elseif (symbolchar_3f(b) or (b == string.byte("~"))) then
- local chars = {}
- local bytestart = byteindex
- while true do
- chars[(#chars + 1)] = b
- b = getb()
- if (not b or not symbolchar_3f(b)) then
- break
- end
+ end
+ if (b and (state0 ~= "done")) then
+ return parse_string_loop(chars, getb(), state0)
+ else
+ return b
+ end
+ end
+ local function parse_string()
+ table.insert(stack, {closer = 34})
+ local chars = {34}
+ if not parse_string_loop(chars, getb(), "base") then
+ badend()
+ end
+ table.remove(stack)
+ local raw = string.char(unpack(chars))
+ local formatted = nil
+ local function _1_(c)
+ return ("\\" .. c:byte())
+ end
+ formatted = raw:gsub("[\1-\31]", _1_)
+ local load_fn = (_G.loadstring or load)(("return " .. formatted))
+ return dispatch(load_fn())
+ end
+ local function parse_prefix(b)
+ table.insert(stack, {prefix = prefixes[b]})
+ local nextb = getb()
+ if whitespace_3f(nextb) then
+ if (b ~= 35) then
+ parse_error("invalid whitespace after quoting prefix")
end
+ table.remove(stack)
+ dispatch(utils.sym("#"))
+ end
+ return ungetb(nextb)
+ end
+ local function parse_sym_loop(chars, b)
+ if (b and symbolchar_3f(b)) then
+ table.insert(chars, b)
+ return parse_sym_loop(chars, getb())
+ else
if b then
ungetb(b)
end
- local rawstr = string.char(unpack(chars))
- if (rawstr == "true") then
- dispatch(true)
- elseif (rawstr == "false") then
- dispatch(false)
- elseif (rawstr == "...") then
- dispatch(utils.varg())
- elseif rawstr:match("^:.+$") then
- dispatch(rawstr:sub(2))
- elseif (rawstr:match("^~") and (rawstr ~= "~=")) then
- parse_error("illegal character: ~")
- else
- local force_number = rawstr:match("^%d")
- local number_with_stripped_underscores = rawstr:gsub("_", "")
- local x = nil
- if force_number then
- x = (tonumber(number_with_stripped_underscores) or parse_error(("could not read number \"" .. rawstr .. "\"")))
- else
- x = tonumber(number_with_stripped_underscores)
- if not x then
- if rawstr:match("%.[0-9]") then
- byteindex = (((byteindex - #rawstr) + rawstr:find("%.[0-9]")) + 1)
- parse_error(("can't start multisym segment " .. "with a digit: " .. rawstr))
- elseif (rawstr:match("[%.:][%.:]") and (rawstr ~= "..") and (rawstr ~= "$...")) then
- byteindex = ((byteindex - #rawstr) + 1 + rawstr:find("[%.:][%.:]"))
- parse_error(("malformed multisym: " .. rawstr))
- elseif rawstr:match(":.+[%.:]") then
- byteindex = ((byteindex - #rawstr) + rawstr:find(":.+[%.:]"))
- parse_error(("method must be last component " .. "of multisym: " .. rawstr))
- else
- x = utils.sym(rawstr, nil, {byteend = byteindex, bytestart = bytestart, filename = filename, line = line})
- end
- end
- end
+ return chars
+ end
+ end
+ local function parse_number(rawstr)
+ local number_with_stripped_underscores = (not rawstr:find("^_") and rawstr:gsub("_", ""))
+ if rawstr:match("^%d") then
+ dispatch((tonumber(number_with_stripped_underscores) or parse_error(("could not read number \"" .. rawstr .. "\""))))
+ return true
+ else
+ local _0_0 = tonumber(number_with_stripped_underscores)
+ if (nil ~= _0_0) then
+ local x = _0_0
dispatch(x)
+ return true
+ else
+ local _ = _0_0
+ return false
end
+ end
+ end
+ local function check_malformed_sym(rawstr)
+ if (rawstr:match("^~") and (rawstr ~= "~=")) then
+ return parse_error("illegal character: ~")
+ elseif rawstr:match("%.[0-9]") then
+ return parse_error(("can't start multisym segment " .. "with a digit: " .. rawstr), (((byteindex - #rawstr) + rawstr:find("%.[0-9]")) + 1))
+ elseif (rawstr:match("[%.:][%.:]") and (rawstr ~= "..") and (rawstr ~= "$...")) then
+ return parse_error(("malformed multisym: " .. rawstr), ((byteindex - #rawstr) + 1 + rawstr:find("[%.:][%.:]")))
+ elseif rawstr:match(":.+[%.:]") then
+ return parse_error(("method must be last component " .. "of multisym: " .. rawstr), ((byteindex - #rawstr) + rawstr:find(":.+[%.:]")))
+ end
+ end
+ local function parse_sym(b)
+ local bytestart = byteindex
+ local rawstr = string.char(unpack(parse_sym_loop({b}, getb())))
+ if (rawstr == "true") then
+ return dispatch(true)
+ elseif (rawstr == "false") then
+ return dispatch(false)
+ elseif (rawstr == "...") then
+ return dispatch(utils.varg())
+ elseif rawstr:match("^:.+$") then
+ return dispatch(rawstr:sub(2))
+ elseif parse_number(rawstr) then
+ return nil
+ elseif check_malformed_sym(rawstr) then
+ return nil
+ else
+ return dispatch(utils.sym(rawstr, nil, {byteend = byteindex, bytestart = bytestart, filename = filename, line = line}))
+ end
+ end
+ local function parse_loop(b)
+ if not b then
+ elseif (b == 59) then
+ skip_comment(getb())
+ elseif (type(delims[b]) == "number") then
+ open_table(b)
+ elseif delims[b] then
+ close_table(b)
+ elseif (b == 34) then
+ parse_string(b)
+ elseif prefixes[b] then
+ parse_prefix(b)
+ elseif (symbolchar_3f(b) or (b == string.byte("~"))) then
+ parse_sym(b)
else
parse_error(("illegal character: " .. string.char(b)))
end
- if done_3f then
- break
+ if not b then
+ return nil
+ elseif done_3f then
+ return true, retval
+ else
+ return parse_loop(skip_whitespace(getb()))
end
end
- return true, retval
+ return parse_loop(skip_whitespace(getb()))
end
local function _0_()
stack = {}
@@ -2940,12 +3135,14 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(..
f0 = _0_
end
for k, x in stablepairs(t) do
- local korv, v = f0(k, x)
- if (korv and not v) then
- table.insert(out0, korv)
- end
- if (korv and v) then
- out0[korv] = v
+ local _1_0, _2_0 = f0(k, x)
+ if ((nil ~= _1_0) and (nil ~= _2_0)) then
+ local key = _1_0
+ local value = _2_0
+ out0[key] = value
+ elseif (nil ~= _1_0) then
+ local value = _1_0
+ table.insert(out0, value)
end
end
return out0
@@ -3000,7 +3197,7 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(..
max = k
end
end
- for i = 1, max, 1 do
+ for i = 1, max do
safe[i] = (((self[i] == nil) and nil_sym) or self[i])
end
return ("(" .. table.concat(map(safe, (tostring2 or tostring)), " ", 1, max) .. ")")
@@ -3096,7 +3293,7 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(..
walk((custom_iterator or pairs), nil, nil, root)
return root
end
- local lua_keywords = {"and", "break", "do", "else", "elseif", "end", "false", "for", "function", "if", "in", "local", "nil", "not", "or", "repeat", "return", "then", "true", "until", "while"}
+ local lua_keywords = {"and", "break", "do", "else", "elseif", "end", "false", "for", "function", "if", "in", "local", "nil", "not", "or", "repeat", "return", "then", "true", "until", "while", "goto"}
for i, v in ipairs(lua_keywords) do
lua_keywords[v] = i
end
@@ -3146,6 +3343,16 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
local compiler = require("fennel.compiler")
local specials = require("fennel.specials")
local repl = require("fennel.repl")
+ local function get_env(env)
+ if (env == "_COMPILER") then
+ local env0 = specials["make-compiler-env"](nil, compiler.scopes.compiler, {})
+ local mt = getmetatable(env0)
+ mt.__index = _G
+ return specials["wrap-env"](env0)
+ else
+ return (env and specials["wrap-env"](env))
+ end
+ end
local function eval(str, options, ...)
local opts = utils.copy(options)
local _ = nil
@@ -3155,22 +3362,17 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
else
_ = nil
end
- local env = nil
- if (opts.env == "_COMPILER") then
- env = specials["wrap-env"](specials["make-compiler-env"](nil, compiler.scopes.compiler, {}))
- else
- env = (opts.env and specials["wrap-env"](opts.env))
- end
+ local env = get_env(opts.env)
local lua_source = compiler["compile-string"](str, opts)
local loader = nil
- local function _2_(...)
+ local function _1_(...)
if opts.filename then
return ("@" .. opts.filename)
else
return str
end
end
- loader = specials["load-code"](lua_source, env, _2_(...))
+ loader = specials["load-code"](lua_source, env, _1_(...))
opts.filename = nil
return loader(...)
end
@@ -3182,7 +3384,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
opts.filename = filename
return eval(source, opts, ...)
end
- local mod = {["compile-stream"] = compiler["compile-stream"], ["compile-string"] = compiler["compile-string"], ["list?"] = utils["list?"], ["load-code"] = specials["load-code"], ["macro-loaded"] = specials["macro-loaded"], ["make-searcher"] = specials["make-searcher"], ["search-module"] = specials["search-module"], ["string-stream"] = parser["string-stream"], ["sym?"] = utils["sym?"], compile = compiler.compile, compile1 = compiler.compile1, compileStream = compiler["compile-stream"], compileString = compiler["compile-string"], doc = specials.doc, dofile = dofile_2a, eval = eval, gensym = compiler.gensym, granulate = parser.granulate, list = utils.list, loadCode = specials["load-code"], macroLoaded = specials["macro-loaded"], makeSearcher = specials["make-searcher"], make_searcher = specials["make-searcher"], mangle = compiler["global-mangling"], metadata = compiler.metadata, parser = parser.parser, path = utils.path, repl = repl, scope = compiler["make-scope"], searchModule = specials["search-module"], searcher = specials["make-searcher"](), stringStream = parser["string-stream"], sym = utils.sym, traceback = compiler.traceback, unmangle = compiler["global-unmangling"], varg = utils.varg, version = "0.6.1-dev"}
+ local mod = {["compile-stream"] = compiler["compile-stream"], ["compile-string"] = compiler["compile-string"], ["list?"] = utils["list?"], ["load-code"] = specials["load-code"], ["macro-loaded"] = specials["macro-loaded"], ["make-searcher"] = specials["make-searcher"], ["search-module"] = specials["search-module"], ["string-stream"] = parser["string-stream"], ["sym?"] = utils["sym?"], compile = compiler.compile, compile1 = compiler.compile1, compileStream = compiler["compile-stream"], compileString = compiler["compile-string"], doc = specials.doc, dofile = dofile_2a, eval = eval, gensym = compiler.gensym, granulate = parser.granulate, list = utils.list, loadCode = specials["load-code"], macroLoaded = specials["macro-loaded"], makeSearcher = specials["make-searcher"], make_searcher = specials["make-searcher"], mangle = compiler["global-mangling"], metadata = compiler.metadata, parser = parser.parser, path = utils.path, repl = repl, scope = compiler["make-scope"], searchModule = specials["search-module"], searcher = specials["make-searcher"](), stringStream = parser["string-stream"], sym = utils.sym, traceback = compiler.traceback, unmangle = compiler["global-unmangling"], varg = utils.varg, version = "0.7.1-dev"}
utils["fennel-module"] = mod
do
local builtin_macros = [===[;; This module contains all the built-in Fennel macros. Unlike all the other
@@ -3192,6 +3394,9 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
;; The code for these macros is somewhat idiosyncratic because it cannot use any
;; macros which have not yet been defined.
+ ;; TODO: some of these macros modify their arguments; we should stop doing that,
+ ;; but in a way that preserves file/line metadata.
+
(fn -> [val ...]
"Thread-first macro.
Take the first value and splice it into the second form as its first argument.
@@ -3275,6 +3480,45 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
`(let ,closable-bindings ,closer
(close-handlers# (xpcall ,bodyfn ,traceback)))))
+ (fn collect [iter-tbl key-value-expr]
+ "Returns a table made by running an iterator and evaluating an expression
+ that returns key-value pairs to be inserted sequentially into the table.
+ This can be thought of as a \"table comprehension\". The provided key-value
+ expression must return either 2 values, or nil.
+
+ For example,
+ (collect [k v (pairs {:apple \"red\" :orange \"orange\"})]
+ (values v k))
+ returns
+ {:red \"apple\" :orange \"orange\"}"
+ (assert (and (sequence? iter-tbl) (>= (length iter-tbl) 2))
+ "expected iterator binding table")
+ (assert (not= nil key-value-expr)
+ "expected key-value expression")
+ `(let [tbl# {}]
+ (each ,iter-tbl
+ (match ,key-value-expr
+ (k# v#) (tset tbl# k# v#)))
+ tbl#))
+
+ (fn icollect [iter-tbl value-expr]
+ "Returns a sequential table made by running an iterator and evaluating an
+ expression that returns values to be inserted sequentially into the table.
+ This can be thought of as a \"list comprehension\".
+
+ For example,
+ (icollect [_ v (ipairs [1 2 3 4 5])] (when (> v 2) (* v v)))
+ returns
+ [9 16 25]"
+ (assert (and (sequence? iter-tbl) (>= (length iter-tbl) 2))
+ "expected iterator binding table")
+ (assert (not= nil value-expr)
+ "expected table value expression")
+ `(let [tbl# []]
+ (each ,iter-tbl
+ (tset tbl# (+ (length tbl#) 1) ,value-expr))
+ tbl#))
+
(fn partial [f ...]
"Returns a function with all arguments partially applied to f."
(let [body (list f ...)]
@@ -3327,9 +3571,8 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
(if (table? a)
(each [_ a (pairs a)]
(check! a))
- (and (not (string.match (tostring a) "^?"))
- (not= (tostring a) "&")
- (not= (tostring a) "..."))
+ (let [as (tostring a)]
+ (and (not (as:match "^?")) (not= as "&") (not= as "_") (not= as "...")))
(table.insert args arity-check-position
`(assert (not= nil ,a)
(string.format "Missing argument %s on %s:%s"
@@ -3347,7 +3590,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
"Define a single macro."
(assert (sym? name) "expected symbol for macro name")
(local args [...])
- `(macros { ,(tostring name) (fn ,name ,(unpack args))}))
+ `(macros { ,(tostring name) (fn ,(unpack args))}))
(fn macrodebug [form return?]
"Print the resulting form after performing macroexpansion.
@@ -3365,32 +3608,63 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
(assert (and binding1 module-name1 (= 0 (% (select :# ...) 2)))
"expected even number of binding/modulename pairs")
(for [i 1 (select :# binding1 module-name1 ...) 2]
- (local (binding modname) (select i binding1 module-name1 ...))
- ;; generate a subscope of current scope, use require-macros
- ;; to bring in macro module. after that, we just copy the
- ;; macros from subscope to scope.
- (local scope (get-scope))
- (local subscope (fennel.scope scope))
- (fennel.compile-string (string.format "(require-macros %q)"
- modname)
- {:scope subscope
- :compiler-env utils.root.options.compiler-env})
- (if (sym? binding)
- ;; bind whole table of macros to table bound to symbol
- (do (tset scope.macros (. binding 1) {})
- (each [k v (pairs subscope.macros)]
- (tset (. scope.macros (. binding 1)) k v)))
+ (let [(binding modname) (select i binding1 module-name1 ...)
+ ;; generate a subscope of current scope, use require-macros
+ ;; to bring in macro module. after that, we just copy the
+ ;; macros from subscope to scope.
+ scope (get-scope)
+ subscope (fennel.scope scope)]
+ (_SPECIALS.require-macros `(require-macros ,modname) subscope {} ast)
+ (if (sym? binding)
+ ;; bind whole table of macros to table bound to symbol
+ (do (tset scope.macros (. binding 1) {})
+ (each [k v (pairs subscope.macros)]
+ (tset (. scope.macros (. binding 1)) k v)))
- ;; 1-level table destructuring for importing individual macros
- (table? binding)
- (each [macro-name [import-key] (pairs binding)]
- (assert (= :function (type (. subscope.macros macro-name)))
- (.. "macro " macro-name " not found in module " modname))
- (tset scope.macros import-key (. subscope.macros macro-name)))))
+ ;; 1-level table destructuring for importing individual macros
+ (table? binding)
+ (each [macro-name [import-key] (pairs binding)]
+ (assert (= :function (type (. subscope.macros macro-name)))
+ (.. "macro " macro-name " not found in module "
+ (tostring modname)))
+ (tset scope.macros import-key (. subscope.macros macro-name))))))
nil)
;;; Pattern matching
+ (fn match-values [vals pattern unifications match-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)))
+
+ (fn match-table [val pattern unifications match-pattern]
+ (let [condition `(and (= (type ,val) :table))
+ bindings []]
+ (each [k pat (pairs pattern)]
+ (if (and (sym? pat) (= "&" (tostring pat)))
+ (do (assert (not (. pattern (+ k 2)))
+ "expected rest argument before last parameter")
+ (table.insert bindings (. pattern (+ k 1)))
+ (table.insert bindings [`(select ,k ((or _G.unpack
+ table.unpack)
+ ,val))]))
+ (and (= :number (type k))
+ (= "&" (tostring (. pattern (- k 1)))))
+ nil ; don't process the pattern right after &; already got it
+ (let [subval `(. ,val ,k)
+ (subcondition subbindings) (match-pattern [subval] pat
+ unifications)]
+ (table.insert condition subcondition)
+ (each [_ b (ipairs subbindings)]
+ (table.insert bindings b)))))
+ (values condition bindings)))
+
(fn match-pattern [vals pattern unifications]
"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
@@ -3407,12 +3681,11 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
(in-scope? (. (multi-sym? pattern) 1))))
(values `(= ,val ,pattern) [])
;; unify a local we've seen already
- (and (sym? pattern)
- (. unifications (tostring pattern)))
+ (and (sym? pattern) (. unifications (tostring pattern)))
(values `(= ,(. unifications (tostring pattern)) ,val) [])
;; bind a fresh local
(sym? pattern)
- (let [wildcard? (= (tostring pattern) "_")]
+ (let [wildcard? (: (tostring pattern) :find "^_")]
(if (not wildcard?) (tset unifications (tostring pattern) val))
(values (if (or wildcard? (string.find (tostring pattern) "^?"))
true `(not= ,(sym :nil) ,val))
@@ -3428,37 +3701,10 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
;; 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))
+ (match-values vals pattern unifications match-pattern)
;; table patterns
(= (type pattern) :table)
- (let [condition `(and (= (type ,val) :table))
- bindings []]
- (each [k pat (pairs pattern)]
- (if (and (sym? pat) (= "&" (tostring pat)))
- (do (assert (not (. pattern (+ k 2)))
- "expected rest argument before last parameter")
- (table.insert bindings (. pattern (+ k 1)))
- (table.insert bindings [`(select ,k ((or _G.unpack
- table.unpack)
- ,val))]))
- (and (= :number (type k))
- (= "&" (tostring (. pattern (- k 1)))))
- nil ; don't process the pattern right after &; already got it
- (let [subval `(. ,val ,k)
- (subcondition subbindings) (match-pattern [subval] pat
- unifications)]
- (table.insert condition subcondition)
- (each [_ b (ipairs subbindings)]
- (table.insert bindings b)))))
- (values condition bindings))
+ (match-table val pattern unifications match-pattern)
;; literal value
(values `(= ,val ,pattern) []))))
@@ -3496,6 +3742,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
{: -> : ->> : -?> : -?>>
: doto : when : with-open
+ : collect : icollect
: partial : lambda
: pick-args : pick-values
: macro : macrodebug : import-macros
@@ -3579,7 +3826,7 @@ end
for i = #arg, 1, -1 do
local _0_0 = arg[i]
if (_0_0 == "--no-searcher") then
- options.no_searcher = true
+ options["no-searcher"] = true
table.remove(arg, i)
elseif (_0_0 == "--indent") then
options.indent = table.remove(arg, (i + 1))
@@ -3635,12 +3882,12 @@ for i = #arg, 1, -1 do
table.remove(arg, i)
end
end
-if not options.no_searcher then
- local opts = {}
+local searcher_opts = {}
+if not options["no-searcher"] then
for k, v in pairs(options) do
- opts[k] = v
+ searcher_opts[k] = v
end
- table.insert((package.loaders or package.searchers), fennel["make-searcher"](opts))
+ table.insert((package.loaders or package.searchers), fennel["make-searcher"](searcher_opts))
end
local function try_readline(ok, readline)
if ok then
@@ -3697,14 +3944,13 @@ local function load_initfile()
end
local function repl()
local readline = try_readline(pcall(require, "readline"))
+ searcher_opts.useMetadata = (false ~= options.useMetadata)
options.pp = require("fennelview")
if (false ~= options.fennelrc) then
load_initfile()
end
print(("Welcome to Fennel " .. fennel.version .. " on " .. _VERSION .. "!"))
- if (options.useMetadata ~= false) then
- print("Use (doc something) to view documentation.")
- end
+ print("Use ,help to see available commands.")
if not readline then
print("Try installing readline via luarocks for a better repl experience.")
end
diff --git a/lib/fennel.lua b/lib/fennel.lua
index b693004..08b766b 100644
--- a/lib/fennel.lua
+++ b/lib/fennel.lua
@@ -50,6 +50,82 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
end
return table.concat(spliced_source, "\n")
end
+ local commands = {}
+ local function command_3f(input)
+ return input:match("^%s*,")
+ end
+ commands.help = function(_, _0, on_values)
+ return on_values({"Welcome to Fennel.\nThis is the REPL where you can enter code to be evaluated.\nYou can also run these repl commands:\n\n ,help - show this message\n ,reload module-name - reload the specified module\n ,reset - erase all repl-local scope\n ,exit - leave the repl\n\nUse (doc something) to see descriptions for individual macros and special forms.\n\nFor more information about the language, see https://fennel-lang.org/reference"})
+ end
+ local function reload(module_name, env, on_values, on_error)
+ local _0_0, _1_0 = pcall(specials["load-code"]("return require(...)", env), module_name)
+ if ((_0_0 == true) and (nil ~= _1_0)) then
+ local old = _1_0
+ local _ = nil
+ package.loaded[module_name] = nil
+ _ = nil
+ local ok, new = pcall(require, module_name)
+ local new0 = nil
+ if not ok then
+ on_values(new)
+ new0 = old
+ else
+ new0 = new
+ end
+ if ((type(old) == "table") and (type(new0) == "table")) then
+ for k, v in pairs(new0) do
+ old[k] = v
+ end
+ for k in pairs(old) do
+ if (nil == new0[k]) then
+ old[k] = nil
+ end
+ end
+ package.loaded[module_name] = old
+ end
+ return on_values({"ok"})
+ elseif ((_0_0 == false) and (nil ~= _1_0)) then
+ local msg = _1_0
+ local function _3_()
+ local _2_0 = msg:gsub("\n.*", "")
+ return _2_0
+ end
+ return on_error("Runtime", _3_())
+ end
+ end
+ commands.reload = function(read, env, on_values, on_error)
+ local _0_0, _1_0, _2_0 = pcall(read)
+ if ((_0_0 == true) and (_1_0 == true) and (nil ~= _2_0)) then
+ local module_sym = _2_0
+ return reload(tostring(module_sym), env, on_values, on_error)
+ elseif ((_0_0 == false) and true and true) then
+ local _3fparse_ok = _1_0
+ local _3fmsg = _2_0
+ return on_error("Parse", (_3fmsg or _3fparse_ok))
+ end
+ end
+ commands.reset = function(_, env, on_values)
+ env.___replLocals___ = {}
+ return on_values({"ok"})
+ end
+ local function run_command(input, read, loop, env, on_values, on_error)
+ local command_name = input:match(",([^%s/]+)")
+ do
+ local _0_0 = commands[command_name]
+ if (nil ~= _0_0) then
+ local command = _0_0
+ command(read, env, on_values, on_error)
+ else
+ local _ = _0_0
+ if ("exit" ~= command_name) then
+ on_values({"Unknown command", command_name})
+ end
+ end
+ end
+ if ("exit" ~= command_name) then
+ return loop()
+ end
+ end
local function completer(env, scope, text)
local matches = {}
local input_fragment = text:gsub(".*[%s)(]+", "")
@@ -120,7 +196,7 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
local read, reset = nil, nil
local function _1_(parser_state)
local c = byte_stream(parser_state)
- chars[(#chars + 1)] = c
+ table.insert(chars, c)
return c
end
read, reset = parser.parser(_1_)
@@ -135,6 +211,15 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
end
opts.registerCompleter(_3_)
end
+ local function print_values(...)
+ local vals = {...}
+ local out = {}
+ env._, env.__ = vals[1], vals
+ for i = 1, select("#", ...) do
+ table.insert(out, pp(vals[i]))
+ end
+ return on_values(out)
+ end
local function loop()
for k in pairs(chars) do
chars[k] = nil
@@ -147,6 +232,8 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
clear_stream()
reset()
return loop()
+ elseif command_3f(src_string) then
+ return run_command(src_string, read, loop, env, on_values, on_error)
else
if parse_ok_3f then
do
@@ -156,32 +243,28 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
clear_stream()
on_error("Compile", msg)
elseif ((_4_0 == true) and (nil ~= _5_0)) then
- local source = _5_0
- local source0 = nil
+ local src = _5_0
+ local src0 = nil
if save_locals_3f then
- source0 = splice_save_locals(env, source)
+ src0 = splice_save_locals(env, src)
else
- source0 = source
+ src0 = src
end
- local lua_ok_3f, loader = pcall(specials["load-code"], source0, env)
- if not lua_ok_3f then
+ local _7_0, _8_0 = pcall(specials["load-code"], src0, env)
+ if ((_7_0 == false) and (nil ~= _8_0)) then
+ local msg = _8_0
clear_stream()
- on_error("Lua Compile", loader, source0)
- else
- local _7_0, _8_0 = nil, nil
+ on_error("Lua Compile", msg, src0)
+ elseif (true and (nil ~= _8_0)) then
+ local _0 = _7_0
+ local chunk = _8_0
local function _9_()
- return {loader()}
+ return print_values(chunk())
end
local function _10_(...)
return on_error("Runtime", ...)
end
- _7_0, _8_0 = xpcall(_9_, _10_)
- if ((_7_0 == true) and (nil ~= _8_0)) then
- local ret = _8_0
- env._ = ret[1]
- env.__ = ret
- on_values(utils.map(ret, pp))
- end
+ xpcall(_9_, _10_)
end
end
end
@@ -304,7 +387,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
return compile_body(opts.target, opts.tail)
elseif opts.nval then
local syms = {}
- for i = 1, opts.nval, 1 do
+ for i = 1, opts.nval do
local s = ((pre_syms and pre_syms[i]) or compiler.gensym(scope))
syms[i] = s
retexprs[i] = utils.expr(s, "sym")
@@ -332,10 +415,10 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
local exprs = {}
for i = 2, len do
local subexprs = compiler.compile1(ast[i], scope, parent, {nval = ((i ~= len) and 1)})
- exprs[(#exprs + 1)] = subexprs[1]
+ table.insert(exprs, subexprs[1])
if (i == len) then
- for j = 2, #subexprs, 1 do
- exprs[(#exprs + 1)] = subexprs[j]
+ for j = 2, #subexprs do
+ table.insert(exprs, subexprs[j])
end
end
end
@@ -398,7 +481,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
elseif utils["table?"](arg) then
local raw = utils.sym(compiler.gensym(scope))
local declared = compiler["declare-local"](raw, {}, f_scope, ast)
- compiler.destructure(arg, raw, ast, f_scope, f_chunk, {declaration = true, nomulti = true})
+ compiler.destructure(arg, raw, ast, f_scope, f_chunk, {declaration = true, nomulti = true, symtype = "arg"})
return declared
else
return compiler.assert(false, ("expected symbol for function parameter: %s"):format(tostring(arg)), ast[2])
@@ -412,14 +495,16 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
else
index0, docstring = index, nil
end
- for i = (index0 + 1), #ast, 1 do
+ for i = (index0 + 1), #ast do
compiler.compile1(ast[i], f_scope, f_chunk, {nval = (((i ~= #ast) and 0) or nil), tail = (i == #ast)})
end
+ local _2_
if local_fn_3f then
- compiler.emit(parent, ("local function %s(%s)"):format(fn_name, table.concat(arg_name_list, ", ")), ast)
+ _2_ = "local function %s(%s)"
else
- compiler.emit(parent, ("%s = function(%s)"):format(fn_name, table.concat(arg_name_list, ", ")), ast)
+ _2_ = "%s = function(%s)"
end
+ compiler.emit(parent, string.format(_2_, fn_name, table.concat(arg_name_list, ", ")), ast)
compiler.emit(parent, f_chunk, ast)
compiler.emit(parent, "end", ast)
set_fn_metadata(arg_list, docstring, parent, fn_name)
@@ -443,7 +528,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
local target = utils.deref(ast[2])
local special_or_macro = (scope.specials[target] or scope.macros[target])
if special_or_macro then
- return ("print([[%s]])"):format(doc_2a(special_or_macro, target))
+ return ("print(%q)"):format(doc_2a(special_or_macro, target))
else
local value = tostring(compiler.compile1(ast[2], scope, parent, {nval = 1})[1])
return ("print(require('%s').doc(%s, '%s'))"):format((utils.root.options.moduleName or "fennel"), value, tostring(ast[2]))
@@ -453,25 +538,26 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
local function dot(ast, scope, parent)
compiler.assert((1 < #ast), "expected table argument", ast)
local len = #ast
- local lhs = compiler.compile1(ast[2], scope, parent, {nval = 1})
+ local _0_ = compiler.compile1(ast[2], scope, parent, {nval = 1})
+ local lhs = _0_[1]
if (len == 2) then
- return tostring(lhs[1])
+ return tostring(lhs)
else
local indices = {}
- for i = 3, len, 1 do
+ for i = 3, len do
local index = ast[i]
if ((type(index) == "string") and utils["valid-lua-identifier?"](index)) then
table.insert(indices, ("." .. index))
else
- local _0_ = compiler.compile1(index, scope, parent, {nval = 1})
- local index0 = _0_[1]
+ local _1_ = compiler.compile1(index, scope, parent, {nval = 1})
+ local index0 = _1_[1]
table.insert(indices, ("[" .. tostring(index0) .. "]"))
end
end
- if utils["table?"](ast[2]) then
- return ("(" .. tostring(lhs[1]) .. ")" .. table.concat(indices))
+ if (tostring(lhs):find("{") or ("nil" == tostring(lhs))) then
+ return ("(" .. tostring(lhs) .. ")" .. table.concat(indices))
else
- return (tostring(lhs[1]) .. table.concat(indices))
+ return (tostring(lhs) .. table.concat(indices))
end
end
end
@@ -479,32 +565,32 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
doc_special(".", {"tbl", "key1", "..."}, "Look up key1 in tbl table. If more args are provided, do a nested lookup.")
SPECIALS.global = function(ast, scope, parent)
compiler.assert((#ast == 3), "expected name and value", ast)
- compiler.destructure(ast[2], ast[3], ast, scope, parent, {forceglobal = true, nomulti = true})
+ compiler.destructure(ast[2], ast[3], ast, scope, parent, {forceglobal = true, nomulti = true, symtype = "global"})
return nil
end
doc_special("global", {"name", "val"}, "Set name as a global with val.")
SPECIALS.set = function(ast, scope, parent)
compiler.assert((#ast == 3), "expected name and value", ast)
- compiler.destructure(ast[2], ast[3], ast, scope, parent, {noundef = true})
+ compiler.destructure(ast[2], ast[3], ast, scope, parent, {noundef = true, symtype = "set"})
return nil
end
doc_special("set", {"name", "val"}, "Set a local variable to a new value. Only works on locals using var.")
local function set_forcibly_21_2a(ast, scope, parent)
compiler.assert((#ast == 3), "expected name and value", ast)
- compiler.destructure(ast[2], ast[3], ast, scope, parent, {forceset = true})
+ compiler.destructure(ast[2], ast[3], ast, scope, parent, {forceset = true, symtype = "set"})
return nil
end
SPECIALS["set-forcibly!"] = set_forcibly_21_2a
local function local_2a(ast, scope, parent)
compiler.assert((#ast == 3), "expected name and value", ast)
- compiler.destructure(ast[2], ast[3], ast, scope, parent, {declaration = true, nomulti = true})
+ compiler.destructure(ast[2], ast[3], ast, scope, parent, {declaration = true, nomulti = true, symtype = "local"})
return nil
end
SPECIALS["local"] = local_2a
doc_special("local", {"name", "val"}, "Introduce new top-level immutable local.")
SPECIALS.var = function(ast, scope, parent)
compiler.assert((#ast == 3), "expected name and value", ast)
- compiler.destructure(ast[2], ast[3], ast, scope, parent, {declaration = true, isvar = true, nomulti = true})
+ compiler.destructure(ast[2], ast[3], ast, scope, parent, {declaration = true, isvar = true, nomulti = true, symtype = "var"})
return nil
end
doc_special("var", {"name", "val"}, "Introduce new mutable local.")
@@ -514,13 +600,13 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
compiler.assert((utils["list?"](bindings) or utils["table?"](bindings)), "expected binding table", ast)
compiler.assert(((#bindings % 2) == 0), "expected even number of name/value bindings", ast[2])
compiler.assert((#ast >= 3), "expected body expression", ast[1])
- for _ = 1, (opts.nval or 0), 1 do
+ for _ = 1, (opts.nval or 0) do
table.insert(pre_syms, compiler.gensym(scope))
end
local sub_scope = compiler["make-scope"](scope)
local sub_chunk = {}
for i = 1, #bindings, 2 do
- compiler.destructure(bindings[i], bindings[(i + 1)], ast, sub_scope, sub_chunk, {declaration = true, nomulti = true})
+ compiler.destructure(bindings[i], bindings[(i + 1)], ast, sub_scope, sub_chunk, {declaration = true, nomulti = true, symtype = "let"})
end
return SPECIALS["do"](ast, scope, parent, opts, 3, sub_chunk, sub_scope, pre_syms)
end
@@ -529,9 +615,10 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
compiler.assert((#ast > 3), "expected table, key, and value arguments", ast)
local root = compiler.compile1(ast[2], scope, parent, {nval = 1})[1]
local keys = {}
- for i = 3, (#ast - 1), 1 do
- local key = compiler.compile1(ast[i], scope, parent, {nval = 1})[1]
- keys[(#keys + 1)] = tostring(key)
+ for i = 3, (#ast - 1) do
+ local _0_ = compiler.compile1(ast[i], scope, parent, {nval = 1})
+ local key = _0_[1]
+ table.insert(keys, tostring(key))
end
local value = compiler.compile1(ast[#ast], scope, parent, {nval = 1})[1]
local rootstr = tostring(root)
@@ -550,7 +637,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
elseif (opts.nval and (opts.nval ~= 0) and not opts.target) then
local accum = {}
local target_exprs = {}
- for i = 1, opts.nval, 1 do
+ for i = 1, opts.nval do
local s = compiler.gensym(scope)
accum[i] = s
target_exprs[i] = utils.expr(s, "sym")
@@ -634,13 +721,13 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
compiler.emit(parent, "end", ast)
return utils.expr(("%s(%s)"):format(tostring(s), iifeargs), "statement")
elseif (wrapper == "none") then
- for i = 1, #buffer, 1 do
+ for i = 1, #buffer do
compiler.emit(parent, buffer[i], ast)
end
return {returned = true}
else
compiler.emit(parent, ("local %s"):format(inner_target), ast)
- for i = 1, #buffer, 1 do
+ for i = 1, #buffer do
compiler.emit(parent, buffer[i], ast)
end
return target_exprs
@@ -670,7 +757,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
local chunk = {}
compiler.emit(parent, ("for %s in %s do"):format(table.concat(bind_vars, ", "), table.concat(val_names, ", ")), ast)
for raw, args in utils.stablepairs(destructures) do
- compiler.destructure(args, raw, ast, sub_scope, chunk, {declaration = true, nomulti = true})
+ compiler.destructure(args, raw, ast, sub_scope, chunk, {declaration = true, nomulti = true, symtype = "each"})
end
compiler["apply-manglings"](sub_scope, new_manglings, ast)
compile_do(ast, sub_scope, chunk, 3)
@@ -684,8 +771,8 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
local len2 = #parent
local sub_chunk = {}
if (len1 ~= len2) then
- for i = (len1 + 1), len2, 1 do
- sub_chunk[(#sub_chunk + 1)] = parent[i]
+ for i = (len1 + 1), len2 do
+ table.insert(sub_chunk, parent[i])
parent[i] = nil
end
compiler.emit(parent, "while true do", ast)
@@ -707,7 +794,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
local chunk = {}
compiler.assert(utils["sym?"](binding_sym), ("unable to bind %s %s"):format(type(binding_sym), tostring(binding_sym)), ast[2])
compiler.assert((#ast >= 3), "expected body expression", ast[1])
- for i = 1, math.min(#ranges, 3), 1 do
+ for i = 1, math.min(#ranges, 3) do
range_args[i] = tostring(compiler.compile1(ranges[i], sub_scope, parent, {nval = 1})[1])
end
compiler.emit(parent, ("for %s = %s do"):format(compiler["declare-local"](binding_sym, {}, sub_scope, ast), table.concat(range_args, ", ")), ast)
@@ -717,7 +804,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
end
SPECIALS["for"] = for_2a
doc_special("for", {"[index start stop step?]", "..."}, "Numeric loop construct.\nEvaluates body once for each value between start and stop (inclusive).")
- local function native_method_call(ast, scope, parent, target, args)
+ local function native_method_call(ast, _scope, _parent, target, args)
local _0_ = ast
local _ = _0_[1]
local _0 = _0_[2]
@@ -769,8 +856,12 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
doc_special(":", {"tbl", "method-name", "..."}, "Call the named method on tbl with the provided args.\nMethod name doesn't have to be known at compile-time; if it is, use\n(tbl:method-name ...) instead.")
SPECIALS.comment = function(ast, _, parent)
local els = {}
- for i = 2, #ast, 1 do
- els[(#els + 1)] = tostring(ast[i]):gsub("\n", " ")
+ for i = 2, #ast do
+ local function _1_()
+ local _0_0 = tostring(ast[i]):gsub("\n", " ")
+ return _0_0
+ end
+ table.insert(els, _1_())
end
return compiler.emit(parent, ("-- " .. table.concat(els, " ")), ast)
end
@@ -842,10 +933,10 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
return utils.expr(zero_arity, "literal")
else
local operands = {}
- for i = 2, len, 1 do
+ for i = 2, len do
local subexprs = nil
local _1_
- if (i == 1) then
+ if (i ~= len) then
_1_ = 1
else
_1_ = nil
@@ -968,7 +1059,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
doc_special("quote", {"x"}, "Quasiquote the following form. Only works in macro/compiler scope.")
local already_warned_3f = {}
local compile_env_warning = ("WARNING: Attempting to %s %s in compile" .. " scope.\nIn future versions of Fennel this will not" .. " be allowed without the\n--no-compiler-sandbox flag" .. " or passing :compiler-env _G in options.\n")
- local function compiler_env_warn(env, key)
+ local function compiler_env_warn(_, key)
local v = _G[key]
if (v and io and io.stderr and not already_warned_3f[key]) then
already_warned_3f[key] = true
@@ -985,8 +1076,8 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
compiler.assert(compiler.scopes.macro, "must call from macro", ast)
return compiler.scopes.macro.manglings[tostring(symbol)]
end
- local function _3_()
- return utils.sym(compiler.gensym((compiler.scopes.macro or scope)))
+ local function _3_(base)
+ return utils.sym(compiler.gensym((compiler.scopes.macro or scope), base))
end
local function _4_(form)
compiler.assert(compiler.scopes.macro, "must call from macro", ast)
@@ -1036,17 +1127,19 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
return find_in_path(1)
end
local function make_searcher(options)
- local opts = utils.copy(utils.root.options)
- for k, v in pairs((options or {})) do
- opts[k] = v
- end
local function _1_(module_name)
- local filename = search_module(module_name)
- if filename then
- local function _2_(mod_name)
- return utils["fennel-module"].dofile(filename, opts, mod_name)
+ local opts = utils.copy(utils.root.options)
+ for k, v in pairs((options or {})) do
+ opts[k] = v
+ end
+ opts["module-name"] = module_name
+ local _2_0 = search_module(module_name)
+ if (nil ~= _2_0) then
+ local filename = _2_0
+ local function _3_(...)
+ return utils["fennel-module"].dofile(filename, opts, ...)
end
- return _2_
+ return _3_, filename
end
end
return _1_
@@ -1061,7 +1154,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
local function compiler_env_domodule(modname, env, _3fast)
local filename = compiler.assert(search_module(modname), (modname .. " module not found."), _3fast)
local globals = macro_globals(env, current_global_names())
- return utils["fennel-module"].dofile(filename, {allowedGlobals = globals, env = env, scope = compiler.scopes.compiler, useMetadata = utils.root.options.useMetadata})
+ return utils["fennel-module"].dofile(filename, {allowedGlobals = globals, env = env, scope = compiler.scopes.compiler, useMetadata = utils.root.options.useMetadata}, modname, filename)
end
local macro_loaded = {}
local function metadata_only_fennel(modname)
@@ -1085,9 +1178,12 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
end
return nil
end
- SPECIALS["require-macros"] = function(ast, scope, parent)
- compiler.assert((#ast == 2), "Expected one module name argument", ast)
- local modname = ast[2]
+ SPECIALS["require-macros"] = function(ast, scope, parent, real_ast)
+ compiler.assert((#ast == 2), "Expected one module name argument", (real_ast or ast))
+ local filename = (ast[2].filename or ast.filename)
+ local modname_code = compiler.compile(ast[2])
+ local modname = load_code(modname_code, nil, filename)(utils.root.options["module-name"], filename)
+ compiler.assert((type(modname) == "string"), "module name must compile to string", (real_ast or ast))
if not macro_loaded[modname] then
local env = make_compiler_env(ast, scope, parent)
macro_loaded[modname] = compiler_env_domodule(modname, env, ast)
@@ -1095,7 +1191,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
return add_macros(macro_loaded[modname], ast, scope, parent)
end
doc_special("require-macros", {"macro-module-name"}, "Load given module and use its contents as macro definitions in current scope.\nMacro module should return a table of macro functions with string keys.\nConsider using import-macros instead as it is more flexible.")
- local function emit_fennel(src, path, opts, sub_chunk)
+ local function emit_included_fennel(src, path, opts, sub_chunk)
local subscope = compiler["make-scope"](utils.root.scope.parent)
local forms = {}
if utils.root.options.requireAsInclude then
@@ -1107,7 +1203,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
for i = 1, #forms do
local subopts = nil
if (i == #forms) then
- subopts = {nval = 1, tail = true}
+ subopts = {tail = true}
else
subopts = {nval = 0}
end
@@ -1145,7 +1241,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
table.insert(utils.root.chunk, i, v)
end
if fennel_3f then
- emit_fennel(src, path, opts, sub_chunk)
+ emit_included_fennel(src, path, opts, sub_chunk)
else
compiler.emit(sub_chunk, src, ast)
end
@@ -1195,7 +1291,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
local opts = utils.copy(utils.root.options)
opts.scope = compiler["make-scope"](compiler.scopes.compiler)
opts.allowedGlobals = macro_globals(env, current_global_names())
- return load_code(compiler.compile(ast, opts), wrap_env(env))()
+ return load_code(compiler.compile(ast, opts), wrap_env(env))(opts["module-name"], ast.filename)
end
SPECIALS.macros = function(ast, scope, parent)
compiler.assert((#ast == 2), "Expected one table argument", ast)
@@ -1292,12 +1388,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
end
local allowed_globals = nil
local function global_allowed(name)
- local found_3f = not allowed_globals
- if not allowed_globals then
- return true
- else
- return utils["member?"](name, allowed_globals)
- end
+ return (not allowed_globals or utils["member?"](name, allowed_globals))
end
local function unique_mangling(original, mangling, scope, append)
if scope.unmanglings[mangling] then
@@ -1308,7 +1399,6 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
end
local function local_mangling(str, scope, ast, temp_manglings)
assert_compile(not utils["multi-sym?"](str), ("unexpected multi symbol " .. str), ast)
- local append = 0
local raw = nil
if (utils["lua-keywords"][str] or str:match("^%d")) then
raw = ("_" .. str)
@@ -1337,7 +1427,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
end
local function combine_parts(parts, scope)
local ret = (scope.manglings[parts[1]] or global_mangling(parts[1]))
- for i = 2, #parts, 1 do
+ for i = 2, #parts do
if utils["valid-lua-identifier?"](parts[i]) then
if (parts["multi-sym-method-call"] and (i == #parts)) then
ret = (ret .. ":" .. parts[i])
@@ -1356,7 +1446,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
mangling = ((base or "") .. "_" .. append .. "_")
append = (append + 1)
end
- scope.unmanglings[mangling] = true
+ scope.unmanglings[mangling] = (base or true)
return mangling
end
local function autogensym(base, scope)
@@ -1377,6 +1467,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
end
local function check_binding_valid(symbol, scope, ast)
local name = utils.deref(symbol)
+ assert_compile(not name:find("&"), "illegal character: &", symbol)
assert_compile(not (scope.specials[name] or scope.macros[name]), ("local %s was overshadowed by a special form or macro"):format(name), ast)
return assert_compile(not utils["quoted?"](symbol), string.format("macro tried to bind %s without gensym", name), symbol)
end
@@ -1429,10 +1520,10 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
elseif ((#chunk >= 3) and (chunk[(#chunk - 2)].leaf == "do") and not chunk[(#chunk - 1)].leaf and (chunk[#chunk].leaf == "end")) then
local kid = peephole(chunk[(#chunk - 1)])
local new_chunk = {ast = chunk.ast}
- for i = 1, (#chunk - 3), 1 do
+ for i = 1, (#chunk - 3) do
table.insert(new_chunk, peephole(chunk[i]))
end
- for i = 1, #kid, 1 do
+ for i = 1, #kid do
table.insert(new_chunk, kid[i])
end
return new_chunk
@@ -1471,7 +1562,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
local code = chunk.leaf
local info = chunk.ast
if sm then
- sm[(#sm + 1)] = ((info and info.line) or ( - 1))
+ table.insert(sm, ((info and info.line) or ( - 1)))
end
return code
else
@@ -1520,7 +1611,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
local sm = {}
local ret = flatten_chunk(sm, chunk0, options.indent, 0)
if sm then
- sm.short_src = (options.filename or ret)
+ sm.short_src = make_short_src((options.filename or options.source or ret))
if options.filename then
sm.key = ("@" .. options.filename)
else
@@ -1561,7 +1652,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
end
local function keep_side_effects(exprs, chunk, start, ast)
local start0 = (start or 1)
- for j = start0, #exprs, 1 do
+ for j = start0, #exprs do
local se = exprs[j]
if ((se.type == "expression") and (se[1] ~= "nil")) then
emit(chunk, string.format("do local _ = %s end", tostring(se)), ast)
@@ -1579,11 +1670,11 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
if (n ~= len) then
if (len > n) then
keep_side_effects(exprs, parent, (n + 1), ast)
- for i = (n + 1), len, 1 do
+ for i = (n + 1), len do
exprs[i] = nil
end
else
- for i = (#exprs + 1), n, 1 do
+ for i = (#exprs + 1), n do
exprs[i] = utils.expr("nil", "literal")
end
end
@@ -1673,6 +1764,31 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
return exprs2
end
end
+ local function compile_function_call(ast, scope, parent, opts, compile1, len)
+ local fargs = {}
+ local fcallee = compile1(ast[1], scope, parent, {nval = 1})[1]
+ assert_compile((fcallee.type ~= "literal"), ("cannot call literal value " .. tostring(ast[1])), ast)
+ for i = 2, len do
+ local subexprs = nil
+ local _0_
+ if (i ~= len) then
+ _0_ = 1
+ else
+ _0_ = nil
+ end
+ subexprs = compile1(ast[i], scope, parent, {nval = _0_})
+ table.insert(fargs, (subexprs[1] or utils.expr("nil", "literal")))
+ if (i == len) then
+ for j = 2, #subexprs do
+ table.insert(fargs, subexprs[j])
+ end
+ else
+ keep_side_effects(subexprs, parent, 2, ast[i])
+ end
+ end
+ local call = string.format("%s(%s)", tostring(fcallee), exprs1(fargs))
+ return handle_compile_opts({utils.expr(call, "statement")}, parent, opts, ast)
+ end
local function compile_call(ast, scope, parent, opts, compile1)
utils.hook("call", ast, scope)
local len = #ast
@@ -1685,28 +1801,10 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
elseif (multi_sym_parts and multi_sym_parts["multi-sym-method-call"]) then
local table_with_method = table.concat({unpack(multi_sym_parts, 1, (#multi_sym_parts - 1))}, ".")
local method_to_call = multi_sym_parts[#multi_sym_parts]
- local new_ast = utils.list(utils.sym(":", scope), utils.sym(table_with_method, scope), method_to_call)
- for i = 2, len, 1 do
- new_ast[(#new_ast + 1)] = ast[i]
- end
+ local new_ast = utils.list(utils.sym(":", scope), utils.sym(table_with_method, scope), method_to_call, select(2, unpack(ast)))
return compile1(new_ast, scope, parent, opts)
else
- local fargs = {}
- local fcallee = compile1(ast[1], scope, parent, {nval = 1})[1]
- assert_compile((fcallee.type ~= "literal"), ("cannot call literal value " .. tostring(first)), ast)
- for i = 2, len, 1 do
- local subexprs = compile1(ast[i], scope, parent, {nval = (((i ~= len) and 1) or nil)})
- fargs[(#fargs + 1)] = (subexprs[1] or utils.expr("nil", "literal"))
- if (i == len) then
- for j = 2, #subexprs, 1 do
- fargs[(#fargs + 1)] = subexprs[j]
- end
- else
- keep_side_effects(subexprs, parent, 2, ast[i])
- end
- end
- local call = string.format("%s(%s)", tostring(fcallee), exprs1(fargs))
- return handle_compile_opts({utils.expr(call, "statement")}, parent, opts, ast)
+ return compile_function_call(ast, scope, parent, opts, compile1, len)
end
end
local function compile_varg(ast, scope, parent, opts)
@@ -1724,7 +1822,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
end
return handle_compile_opts({e}, parent, opts, ast)
end
- local function compile_scalar(ast, scope, parent, opts)
+ local function compile_scalar(ast, _scope, parent, opts)
local serialize = nil
do
local _0_0 = type(ast)
@@ -1747,9 +1845,9 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
end
local function compile_table(ast, scope, parent, opts, compile1)
local buffer = {}
- for i = 1, #ast, 1 do
+ for i = 1, #ast do
local nval = ((i ~= #ast) and 1)
- buffer[(#buffer + 1)] = exprs1(compile1(ast[i], scope, parent, {nval = nval}))
+ table.insert(buffer, exprs1(compile1(ast[i], scope, parent, {nval = nval})))
end
local function write_other_values(k)
if ((type(k) ~= "number") or (math.floor(k) ~= k) or (k < 1) or (k > #ast)) then
@@ -1807,6 +1905,8 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
local isvar = _0_["isvar"]
local nomulti = _0_["nomulti"]
local noundef = _0_["noundef"]
+ local symtype = _0_["symtype"]
+ local symtype0 = ("_" .. (symtype or "dst"))
local setter = nil
if declaration then
setter = "local %s = %s"
@@ -1818,7 +1918,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
local raw = symbol[1]
assert_compile(not (nomulti and utils["multi-sym?"](raw)), ("unexpected multi symbol " .. raw), up1)
if declaration then
- return declare_local(symbol, {var = isvar}, scope, symbol, new_manglings)
+ return declare_local(symbol, nil, scope, symbol, new_manglings)
else
local parts = (utils["multi-sym?"](raw) or {raw})
local meta = scope.symmeta[parts[1]]
@@ -1866,72 +1966,101 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
end
return ret
end
- local function destructure1(left, rightexprs, up1, top)
- if (utils["sym?"](left) and (left[1] ~= "nil")) then
- local lname = getname(left, up1)
- check_binding_valid(left, scope, left)
- if top then
- compile_top_target({lname})
+ local function destructure_sym(left, rightexprs, up1, top_3f)
+ local lname = getname(left, up1)
+ check_binding_valid(left, scope, left)
+ if top_3f then
+ compile_top_target({lname})
+ else
+ emit(parent, setter:format(lname, exprs1(rightexprs)), left)
+ end
+ if declaration then
+ scope.symmeta[utils.deref(left)] = {var = isvar}
+ return nil
+ end
+ end
+ local function destructure_table(left, rightexprs, top_3f, destructure1)
+ local s = gensym(scope, symtype0)
+ local right = nil
+ do
+ local _2_0 = nil
+ if top_3f then
+ _2_0 = exprs1(compile1(from, scope, parent))
else
- emit(parent, setter:format(lname, exprs1(rightexprs)), left)
+ _2_0 = exprs1(rightexprs)
end
- elseif utils["table?"](left) then
- local s = gensym(scope)
- local right = nil
- if top then
- right = exprs1(compile1(from, scope, parent))
- else
- right = exprs1(rightexprs)
- end
- if (right == "") then
+ if (_2_0 == "") then
right = "nil"
+ elseif (nil ~= _2_0) then
+ local right0 = _2_0
+ right = right0
+ else
+ right = nil
end
- emit(parent, string.format("local %s = %s", s, right), left)
- for k, v in utils.stablepairs(left) do
- if (utils["sym?"](left[k]) and (left[k][1] == "&")) then
- assert_compile(((type(k) == "number") and not left[(k + 2)]), "expected rest argument before last parameter", left)
+ end
+ emit(parent, string.format("local %s = %s", s, right), left)
+ for k, v in utils.stablepairs(left) do
+ if not (("number" == type(k)) and tostring(left[(k - 1)]):find("^&")) then
+ if (utils["sym?"](v) and (utils.deref(v) == "&")) then
local unpack_str = "{(table.unpack or unpack)(%s, %s)}"
local formatted = string.format(unpack_str, s, k)
local subexpr = utils.expr(formatted, "expression")
+ assert_compile((utils["sequence?"](left) and (nil == left[(k + 2)])), "expected rest argument before last parameter", left)
destructure1(left[(k + 1)], {subexpr}, left)
- return
+ elseif (utils["sym?"](k) and (utils.deref(k) == "&as")) then
+ destructure_sym(v, {utils.expr(tostring(s))}, left)
+ elseif (utils["sequence?"](left) and (utils.deref(v) == "&as")) then
+ local _, next_sym, trailing = select(k, unpack(left))
+ assert_compile((nil == trailing), "expected &as argument before last parameter", left)
+ destructure_sym(next_sym, {utils.expr(tostring(s))}, left)
else
- if (utils["sym?"](k) and (tostring(k) == ":") and utils["sym?"](v)) then
- k = tostring(v)
+ local key = nil
+ if (type(k) == "string") then
+ key = serialize_string(k)
+ else
+ key = k
end
- if (type(k) ~= "number") then
- k = serialize_string(k)
- end
- local subexpr = utils.expr(string.format("%s[%s]", s, k), "expression")
+ local subexpr = utils.expr(string.format("%s[%s]", s, key), "expression")
destructure1(v, {subexpr}, left)
end
end
- elseif utils["list?"](left) then
- local left_names, tables = {}, {}
- for i, name in ipairs(left) do
- local symname = nil
- if utils["sym?"](name) then
- symname = getname(name, up1)
- else
- symname = gensym(scope)
- tables[i] = {name, utils.expr(symname, "sym")}
- end
- table.insert(left_names, symname)
- end
- if top then
- compile_top_target(left_names)
+ end
+ return nil
+ end
+ local function destructure_values(left, up1, top_3f, destructure1)
+ local left_names, tables = {}, {}
+ for i, name in ipairs(left) do
+ if utils["sym?"](name) then
+ table.insert(left_names, getname(name, up1))
else
- local lvalue = table.concat(left_names, ", ")
- local setting = setter:format(lvalue, exprs1(rightexprs))
- emit(parent, setting, left)
+ local symname = gensym(scope, symtype0)
+ table.insert(left_names, symname)
+ tables[i] = {name, utils.expr(symname, "sym")}
end
- for _, pair in utils.stablepairs(tables) do
- destructure1(pair[1], {pair[2]}, left)
+ end
+ assert_compile(top_3f, "can't nest multi-value destructuring", left)
+ compile_top_target(left_names)
+ if declaration then
+ for _, sym in ipairs(left) do
+ scope.symmeta[utils.deref(sym)] = {var = isvar}
end
+ end
+ for _, pair in utils.stablepairs(tables) do
+ destructure1(pair[1], {pair[2]}, left)
+ end
+ return nil
+ end
+ local function destructure1(left, rightexprs, up1, top_3f)
+ if (utils["sym?"](left) and (left[1] ~= "nil")) then
+ destructure_sym(left, rightexprs, up1, top_3f)
+ elseif utils["table?"](left) then
+ destructure_table(left, rightexprs, top_3f, destructure1)
+ elseif utils["list?"](left) then
+ destructure_values(left, up1, top_3f, destructure1)
else
assert_compile(false, string.format("unable to bind %s %s", type(left), tostring(left)), (((type(up1[2]) == "table") and up1[2]) or up1))
end
- if top then
+ if top_3f then
return {returned = true}
end
end
@@ -1962,10 +2091,10 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
scope.specials.require = require_include
end
utils.root.chunk, utils.root.scope, utils.root.options = chunk, scope, opts
- for ok, val in parser.parser(strm, opts.filename, opts) do
- vals[(#vals + 1)] = val
+ for _, val in parser.parser(strm, opts.filename, opts) do
+ table.insert(vals, val)
end
- for i = 1, #vals, 1 do
+ for i = 1, #vals do
local exprs = compile1(vals[i], scope, chunk, {nval = (((i < #vals) and 0) or nil), tail = (i == #vals)})
keep_side_effects(exprs, chunk, nil, vals[i])
end
@@ -2145,11 +2274,7 @@ end
package.preload["fennel.friend"] = package.preload["fennel.friend"] or function(...)
local function ast_source(ast)
local m = getmetatable(ast)
- if (m and m.line and m) then
- return m
- else
- return ast
- end
+ return ((m and m.line and m) or ast or {})
end
local suggestions = {["$ and $... in hashfn are mutually exclusive"] = {"modifying the hashfn so it only contains $... or $, $1, $2, $3, etc"}, ["can't start multisym segment with a digit"] = {"removing the digit", "adding a non-digit before the digit"}, ["cannot call literal value"] = {"checking for typos", "checking for a missing function name"}, ["could not compile value of type "] = {"debugging the macro you're calling not to return a coroutine or userdata"}, ["could not read number (.*)"] = {"removing the non-digit character", "beginning the identifier with a non-digit if it is not meant to be a number"}, ["expected a function.* to call"] = {"removing the empty parentheses", "using square brackets if you want an empty table"}, ["expected binding table"] = {"placing a table here in square brackets containing identifiers to bind"}, ["expected body expression"] = {"putting some code in the body of this form after the bindings"}, ["expected each macro to be function"] = {"ensuring that the value for each key in your macros table contains a function", "avoid defining nested macro tables"}, ["expected even number of name/value bindings"] = {"finding where the identifier or value is missing"}, ["expected even number of values in table literal"] = {"removing a key", "adding a value"}, ["expected local"] = {"looking for a typo", "looking for a local which is used out of its scope"}, ["expected macros to be table"] = {"ensuring your macro definitions return a table"}, ["expected parameters"] = {"adding function parameters as a list of identifiers in brackets"}, ["expected rest argument before last parameter"] = {"moving & to right before the final identifier when destructuring"}, ["expected symbol for function parameter: (.*)"] = {"changing %s to an identifier instead of a literal value"}, ["expected var (.*)"] = {"declaring %s using var instead of let/local", "introducing a new local instead of changing the value of %s"}, ["expected vararg as last parameter"] = {"moving the \"...\" to the end of the parameter list"}, ["expected whitespace before opening delimiter"] = {"adding whitespace"}, ["global (.*) conflicts with local"] = {"renaming local %s"}, ["illegal character: (.)"] = {"deleting or replacing %s", "avoiding reserved characters like \", \\, ', ~, ;, @, `, and comma"}, ["local (.*) was overshadowed by a special form or macro"] = {"renaming local %s"}, ["macro not found in macro module"] = {"checking the keys of the imported macro module's returned table"}, ["macro tried to bind (.*) without gensym"] = {"changing to %s# when introducing identifiers inside macros"}, ["malformed multisym"] = {"ensuring each period or colon is not followed by another period or colon"}, ["may only be used at compile time"] = {"moving this to inside a macro if you need to manipulate symbols/lists", "using square brackets instead of parens to construct a table"}, ["method must be last component"] = {"using a period instead of a colon for field access", "removing segments after the colon", "making the method call, then looking up the field on the result"}, ["mismatched closing delimiter (.), expected (.)"] = {"replacing %s with %s", "deleting %s", "adding matching opening delimiter earlier"}, ["multisym method calls may only be in call position"] = {"using a period instead of a colon to reference a table's fields", "putting parens around this"}, ["unable to bind (.*)"] = {"replacing the %s with an identifier"}, ["unexpected closing delimiter (.)"] = {"deleting %s", "adding matching opening delimiter earlier"}, ["unexpected multi symbol (.*)"] = {"removing periods or colons from %s"}, ["unexpected vararg"] = {"putting \"...\" at the end of the fn parameters if the vararg was intended"}, ["unknown global in strict mode: (.*)"] = {"looking to see if there's a typo", "using the _G table instead, eg. _G.%s if you really want a global", "moving this code to somewhere that %s is in scope", "binding %s as a local in the scope of this code"}, ["unused local (.*)"] = {"fixing a typo so %s is used", "renaming the local to _%s"}, ["use of global (.*) is aliased by a local"] = {"renaming local %s", "refer to the global using _G.%s instead of directly"}}
local unpack = (_G.unpack or table.unpack)
@@ -2208,7 +2333,7 @@ package.preload["fennel.friend"] = package.preload["fennel.friend"] or function(
local bytestart = _1_["bytestart"]
local filename = _1_["filename"]
local line = _1_["line"]
- local ok, codeline, bol, eol = pcall(read_line, filename, line, source)
+ local ok, codeline, bol = pcall(read_line, filename, line, source)
local suggestions0 = suggest(msg)
local out = {msg, ""}
if (ok and codeline) then
@@ -2255,13 +2380,22 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(
index = (index + 1)
return b
else
- c = getchunk(parser_state)
- if (not c or (c == "")) then
+ local _1_0, _2_0, _3_0 = getchunk(parser_state)
+ local _4_
+ do
+ local char = _1_0
+ _4_ = ((nil ~= _1_0) and (char ~= ""))
+ end
+ if _4_ then
+ local char = _1_0
+ c = char
+ index = 2
+ return c:byte()
+ else
+ local _ = _1_0
done_3f = true
return nil
end
- index = 2
- return c:byte(1)
end
end
end
@@ -2272,7 +2406,7 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(
return _0_, _1_
end
local function string_stream(str)
- local str0 = str:gsub("^#![^\n]*\n", "")
+ local str0 = str:gsub("^#!", ";;")
local index = 1
local function _0_()
local r = str0:byte(index)
@@ -2315,198 +2449,241 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(
end
return r
end
- local function parse_error(msg)
- local _0_ = (utils.root.options or {})
+ local function parse_error(msg, byteindex_override)
+ local _0_ = (options or utils.root.options or {})
local source = _0_["source"]
local unfriendly = _0_["unfriendly"]
utils.root.reset()
if unfriendly then
return error(string.format("Parse error in %s:%s: %s", (filename or "unknown"), (line or "?"), msg), 0)
else
- return friend["parse-error"](msg, (filename or "unknown"), (line or "?"), byteindex, source)
+ return friend["parse-error"](msg, (filename or "unknown"), (line or "?"), (byteindex_override or byteindex), source)
end
end
local function parse_stream()
local whitespace_since_dispatch, done_3f, retval = true
local function dispatch(v)
- if (#stack == 0) then
+ local _0_0 = stack[#stack]
+ if (_0_0 == nil) then
retval, done_3f, whitespace_since_dispatch = v, true, false
return nil
- elseif stack[#stack].prefix then
- local stacktop = stack[#stack]
- stack[#stack] = nil
- return dispatch(utils.list(utils.sym(stacktop.prefix), v))
- else
+ elseif ((type(_0_0) == "table") and (nil ~= _0_0.prefix)) then
+ local prefix = _0_0.prefix
+ table.remove(stack)
+ return dispatch(utils.list(utils.sym(prefix), v))
+ elseif (nil ~= _0_0) then
+ local top = _0_0
whitespace_since_dispatch = false
- return table.insert(stack[#stack], v)
+ return table.insert(top, v)
end
end
local function badend()
local accum = utils.map(stack, "closer")
- return parse_error(string.format("expected closing delimiter%s %s", (((#stack == 1) and "") or "s"), string.char(unpack(accum))))
+ local _0_
+ if (#stack == 1) then
+ _0_ = ""
+ else
+ _0_ = "s"
+ end
+ return parse_error(string.format("expected closing delimiter%s %s", _0_, string.char(unpack(accum))))
end
- while true do
- local b = nil
- while true do
- b = getb()
- if (b and whitespace_3f(b)) then
- whitespace_since_dispatch = true
- end
- if (not b or not whitespace_3f(b)) then
- break
- end
+ local function skip_whitespace(b)
+ if (b and whitespace_3f(b)) then
+ whitespace_since_dispatch = true
+ return skip_whitespace(getb())
+ elseif (not b and (#stack > 0)) then
+ return badend()
+ else
+ return b
end
- if not b then
- if (#stack > 0) then
- badend()
- end
- return nil
+ end
+ local function skip_comment(b)
+ if (b and (10 ~= b)) then
+ return skip_comment(getb())
+ else
+ return b
end
- if (b == 59) then
- while true do
- b = getb()
- if (not b or (b == 10)) then
- break
- end
+ end
+ local function open_table(b)
+ if not whitespace_since_dispatch then
+ parse_error(("expected whitespace before opening delimiter " .. string.char(b)))
+ end
+ return table.insert(stack, {bytestart = byteindex, closer = delims[b], filename = filename, line = line})
+ end
+ local function close_list(list)
+ return dispatch(setmetatable(list, getmetatable(utils.list())))
+ end
+ local function close_sequence(tbl)
+ local val = utils.sequence(unpack(tbl))
+ for k, v in pairs(tbl) do
+ getmetatable(val)[k] = v
+ end
+ return dispatch(val)
+ end
+ local function close_curly_table(tbl)
+ local val = {}
+ if ((#tbl % 2) ~= 0) then
+ byteindex = (byteindex - 1)
+ parse_error("expected even number of values in table literal")
+ end
+ setmetatable(val, tbl)
+ for i = 1, #tbl, 2 do
+ if ((tostring(tbl[i]) == ":") and utils["sym?"](tbl[(i + 1)]) and utils["sym?"](tbl[i])) then
+ tbl[i] = tostring(tbl[(i + 1)])
end
- elseif (type(delims[b]) == "number") then
- if not whitespace_since_dispatch then
- parse_error(("expected whitespace before opening delimiter " .. string.char(b)))
- end
- table.insert(stack, setmetatable({bytestart = byteindex, closer = delims[b], filename = filename, line = line}, getmetatable(utils.list())))
- elseif delims[b] then
- local last = stack[#stack]
- if (#stack == 0) then
- parse_error(("unexpected closing delimiter " .. string.char(b)))
- end
- local val = nil
- if (last.closer ~= b) then
- parse_error(("mismatched closing delimiter " .. string.char(b) .. ", expected " .. string.char(last.closer)))
- end
- last.byteend = byteindex
- if (b == 41) then
- val = last
- elseif (b == 93) then
- val = utils.sequence(unpack(last))
- for k, v in pairs(last) do
- getmetatable(val)[k] = v
- end
+ val[tbl[i]] = tbl[(i + 1)]
+ end
+ return dispatch(val)
+ end
+ local function close_table(b)
+ local top = table.remove(stack)
+ if (top == nil) then
+ parse_error(("unexpected closing delimiter " .. string.char(b)))
+ end
+ if (top.closer ~= b) then
+ parse_error(("mismatched closing delimiter " .. string.char(b) .. ", expected " .. string.char(top.closer)))
+ end
+ top.byteend = byteindex
+ if (b == 41) then
+ return close_list(top)
+ elseif (b == 93) then
+ return close_sequence(top)
+ else
+ return close_curly_table(top)
+ end
+ end
+ local function parse_string_loop(chars, b, state)
+ table.insert(chars, b)
+ local state0 = nil
+ do
+ local _0_0 = {state, b}
+ if ((type(_0_0) == "table") and (_0_0[1] == "base") and (_0_0[2] == 92)) then
+ state0 = "backslash"
+ elseif ((type(_0_0) == "table") and (_0_0[1] == "base") and (_0_0[2] == 34)) then
+ state0 = "done"
else
- if ((#last % 2) ~= 0) then
- byteindex = (byteindex - 1)
- parse_error("expected even number of values in table literal")
- end
- val = {}
- setmetatable(val, last)
- for i = 1, #last, 2 do
- if ((tostring(last[i]) == ":") and utils["sym?"](last[(i + 1)]) and utils["sym?"](last[i])) then
- last[i] = tostring(last[(i + 1)])
- end
- val[last[i]] = last[(i + 1)]
- end
+ local _ = _0_0
+ state0 = "base"
end
- stack[#stack] = nil
- dispatch(val)
- elseif (b == 34) then
- local chars = {34}
- local state = "base"
- stack[(#stack + 1)] = {closer = 34}
- while true do
- b = getb()
- chars[(#chars + 1)] = b
- if (state == "base") then
- if (b == 92) then
- state = "backslash"
- elseif (b == 34) then
- state = "done"
- end
- else
- state = "base"
- end
- if (not b or (state == "done")) then
- break
- end
- end
- if not b then
- badend()
- end
- stack[#stack] = nil
- local raw = string.char(unpack(chars))
- local formatted = nil
- local function _2_(c)
- return ("\\" .. c:byte())
- end
- formatted = raw:gsub("[\1-\31]", _2_)
- local load_fn = (_G.loadstring or load)(string.format("return %s", formatted))
- dispatch(load_fn())
- elseif prefixes[b] then
- table.insert(stack, {prefix = prefixes[b]})
- local nextb = getb()
- if whitespace_3f(nextb) then
- if (b ~= 35) then
- parse_error("invalid whitespace after quoting prefix")
- end
- stack[#stack] = nil
- dispatch(utils.sym("#"))
- end
- ungetb(nextb)
- elseif (symbolchar_3f(b) or (b == string.byte("~"))) then
- local chars = {}
- local bytestart = byteindex
- while true do
- chars[(#chars + 1)] = b
- b = getb()
- if (not b or not symbolchar_3f(b)) then
- break
- end
+ end
+ if (b and (state0 ~= "done")) then
+ return parse_string_loop(chars, getb(), state0)
+ else
+ return b
+ end
+ end
+ local function parse_string()
+ table.insert(stack, {closer = 34})
+ local chars = {34}
+ if not parse_string_loop(chars, getb(), "base") then
+ badend()
+ end
+ table.remove(stack)
+ local raw = string.char(unpack(chars))
+ local formatted = nil
+ local function _1_(c)
+ return ("\\" .. c:byte())
+ end
+ formatted = raw:gsub("[\1-\31]", _1_)
+ local load_fn = (_G.loadstring or load)(("return " .. formatted))
+ return dispatch(load_fn())
+ end
+ local function parse_prefix(b)
+ table.insert(stack, {prefix = prefixes[b]})
+ local nextb = getb()
+ if whitespace_3f(nextb) then
+ if (b ~= 35) then
+ parse_error("invalid whitespace after quoting prefix")
end
+ table.remove(stack)
+ dispatch(utils.sym("#"))
+ end
+ return ungetb(nextb)
+ end
+ local function parse_sym_loop(chars, b)
+ if (b and symbolchar_3f(b)) then
+ table.insert(chars, b)
+ return parse_sym_loop(chars, getb())
+ else
if b then
ungetb(b)
end
- local rawstr = string.char(unpack(chars))
- if (rawstr == "true") then
- dispatch(true)
- elseif (rawstr == "false") then
- dispatch(false)
- elseif (rawstr == "...") then
- dispatch(utils.varg())
- elseif rawstr:match("^:.+$") then
- dispatch(rawstr:sub(2))
- elseif (rawstr:match("^~") and (rawstr ~= "~=")) then
- parse_error("illegal character: ~")
- else
- local force_number = rawstr:match("^%d")
- local number_with_stripped_underscores = rawstr:gsub("_", "")
- local x = nil
- if force_number then
- x = (tonumber(number_with_stripped_underscores) or parse_error(("could not read number \"" .. rawstr .. "\"")))
- else
- x = tonumber(number_with_stripped_underscores)
- if not x then
- if rawstr:match("%.[0-9]") then
- byteindex = (((byteindex - #rawstr) + rawstr:find("%.[0-9]")) + 1)
- parse_error(("can't start multisym segment " .. "with a digit: " .. rawstr))
- elseif (rawstr:match("[%.:][%.:]") and (rawstr ~= "..") and (rawstr ~= "$...")) then
- byteindex = ((byteindex - #rawstr) + 1 + rawstr:find("[%.:][%.:]"))
- parse_error(("malformed multisym: " .. rawstr))
- elseif rawstr:match(":.+[%.:]") then
- byteindex = ((byteindex - #rawstr) + rawstr:find(":.+[%.:]"))
- parse_error(("method must be last component " .. "of multisym: " .. rawstr))
- else
- x = utils.sym(rawstr, nil, {byteend = byteindex, bytestart = bytestart, filename = filename, line = line})
- end
- end
- end
+ return chars
+ end
+ end
+ local function parse_number(rawstr)
+ local number_with_stripped_underscores = (not rawstr:find("^_") and rawstr:gsub("_", ""))
+ if rawstr:match("^%d") then
+ dispatch((tonumber(number_with_stripped_underscores) or parse_error(("could not read number \"" .. rawstr .. "\""))))
+ return true
+ else
+ local _0_0 = tonumber(number_with_stripped_underscores)
+ if (nil ~= _0_0) then
+ local x = _0_0
dispatch(x)
+ return true
+ else
+ local _ = _0_0
+ return false
end
+ end
+ end
+ local function check_malformed_sym(rawstr)
+ if (rawstr:match("^~") and (rawstr ~= "~=")) then
+ return parse_error("illegal character: ~")
+ elseif rawstr:match("%.[0-9]") then
+ return parse_error(("can't start multisym segment " .. "with a digit: " .. rawstr), (((byteindex - #rawstr) + rawstr:find("%.[0-9]")) + 1))
+ elseif (rawstr:match("[%.:][%.:]") and (rawstr ~= "..") and (rawstr ~= "$...")) then
+ return parse_error(("malformed multisym: " .. rawstr), ((byteindex - #rawstr) + 1 + rawstr:find("[%.:][%.:]")))
+ elseif rawstr:match(":.+[%.:]") then
+ return parse_error(("method must be last component " .. "of multisym: " .. rawstr), ((byteindex - #rawstr) + rawstr:find(":.+[%.:]")))
+ end
+ end
+ local function parse_sym(b)
+ local bytestart = byteindex
+ local rawstr = string.char(unpack(parse_sym_loop({b}, getb())))
+ if (rawstr == "true") then
+ return dispatch(true)
+ elseif (rawstr == "false") then
+ return dispatch(false)
+ elseif (rawstr == "...") then
+ return dispatch(utils.varg())
+ elseif rawstr:match("^:.+$") then
+ return dispatch(rawstr:sub(2))
+ elseif parse_number(rawstr) then
+ return nil
+ elseif check_malformed_sym(rawstr) then
+ return nil
+ else
+ return dispatch(utils.sym(rawstr, nil, {byteend = byteindex, bytestart = bytestart, filename = filename, line = line}))
+ end
+ end
+ local function parse_loop(b)
+ if not b then
+ elseif (b == 59) then
+ skip_comment(getb())
+ elseif (type(delims[b]) == "number") then
+ open_table(b)
+ elseif delims[b] then
+ close_table(b)
+ elseif (b == 34) then
+ parse_string(b)
+ elseif prefixes[b] then
+ parse_prefix(b)
+ elseif (symbolchar_3f(b) or (b == string.byte("~"))) then
+ parse_sym(b)
else
parse_error(("illegal character: " .. string.char(b)))
end
- if done_3f then
- break
+ if not b then
+ return nil
+ elseif done_3f then
+ return true, retval
+ else
+ return parse_loop(skip_whitespace(getb()))
end
end
- return true, retval
+ return parse_loop(skip_whitespace(getb()))
end
local function _0_()
stack = {}
@@ -2574,12 +2751,14 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(..
f0 = _0_
end
for k, x in stablepairs(t) do
- local korv, v = f0(k, x)
- if (korv and not v) then
- table.insert(out0, korv)
- end
- if (korv and v) then
- out0[korv] = v
+ local _1_0, _2_0 = f0(k, x)
+ if ((nil ~= _1_0) and (nil ~= _2_0)) then
+ local key = _1_0
+ local value = _2_0
+ out0[key] = value
+ elseif (nil ~= _1_0) then
+ local value = _1_0
+ table.insert(out0, value)
end
end
return out0
@@ -2634,7 +2813,7 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(..
max = k
end
end
- for i = 1, max, 1 do
+ for i = 1, max do
safe[i] = (((self[i] == nil) and nil_sym) or self[i])
end
return ("(" .. table.concat(map(safe, (tostring2 or tostring)), " ", 1, max) .. ")")
@@ -2730,7 +2909,7 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(..
walk((custom_iterator or pairs), nil, nil, root)
return root
end
- local lua_keywords = {"and", "break", "do", "else", "elseif", "end", "false", "for", "function", "if", "in", "local", "nil", "not", "or", "repeat", "return", "then", "true", "until", "while"}
+ local lua_keywords = {"and", "break", "do", "else", "elseif", "end", "false", "for", "function", "if", "in", "local", "nil", "not", "or", "repeat", "return", "then", "true", "until", "while", "goto"}
for i, v in ipairs(lua_keywords) do
lua_keywords[v] = i
end
@@ -2779,6 +2958,16 @@ local parser = require("fennel.parser")
local compiler = require("fennel.compiler")
local specials = require("fennel.specials")
local repl = require("fennel.repl")
+local function get_env(env)
+ if (env == "_COMPILER") then
+ local env0 = specials["make-compiler-env"](nil, compiler.scopes.compiler, {})
+ local mt = getmetatable(env0)
+ mt.__index = _G
+ return specials["wrap-env"](env0)
+ else
+ return (env and specials["wrap-env"](env))
+ end
+end
local function eval(str, options, ...)
local opts = utils.copy(options)
local _ = nil
@@ -2788,22 +2977,17 @@ local function eval(str, options, ...)
else
_ = nil
end
- local env = nil
- if (opts.env == "_COMPILER") then
- env = specials["wrap-env"](specials["make-compiler-env"](nil, compiler.scopes.compiler, {}))
- else
- env = (opts.env and specials["wrap-env"](opts.env))
- end
+ local env = get_env(opts.env)
local lua_source = compiler["compile-string"](str, opts)
local loader = nil
- local function _2_(...)
+ local function _1_(...)
if opts.filename then
return ("@" .. opts.filename)
else
return str
end
end
- loader = specials["load-code"](lua_source, env, _2_(...))
+ loader = specials["load-code"](lua_source, env, _1_(...))
opts.filename = nil
return loader(...)
end
@@ -2815,7 +2999,7 @@ local function dofile_2a(filename, options, ...)
opts.filename = filename
return eval(source, opts, ...)
end
-local mod = {["compile-stream"] = compiler["compile-stream"], ["compile-string"] = compiler["compile-string"], ["list?"] = utils["list?"], ["load-code"] = specials["load-code"], ["macro-loaded"] = specials["macro-loaded"], ["make-searcher"] = specials["make-searcher"], ["search-module"] = specials["search-module"], ["string-stream"] = parser["string-stream"], ["sym?"] = utils["sym?"], compile = compiler.compile, compile1 = compiler.compile1, compileStream = compiler["compile-stream"], compileString = compiler["compile-string"], doc = specials.doc, dofile = dofile_2a, eval = eval, gensym = compiler.gensym, granulate = parser.granulate, list = utils.list, loadCode = specials["load-code"], macroLoaded = specials["macro-loaded"], makeSearcher = specials["make-searcher"], make_searcher = specials["make-searcher"], mangle = compiler["global-mangling"], metadata = compiler.metadata, parser = parser.parser, path = utils.path, repl = repl, scope = compiler["make-scope"], searchModule = specials["search-module"], searcher = specials["make-searcher"](), stringStream = parser["string-stream"], sym = utils.sym, traceback = compiler.traceback, unmangle = compiler["global-unmangling"], varg = utils.varg, version = "0.6.1-dev"}
+local mod = {["compile-stream"] = compiler["compile-stream"], ["compile-string"] = compiler["compile-string"], ["list?"] = utils["list?"], ["load-code"] = specials["load-code"], ["macro-loaded"] = specials["macro-loaded"], ["make-searcher"] = specials["make-searcher"], ["search-module"] = specials["search-module"], ["string-stream"] = parser["string-stream"], ["sym?"] = utils["sym?"], compile = compiler.compile, compile1 = compiler.compile1, compileStream = compiler["compile-stream"], compileString = compiler["compile-string"], doc = specials.doc, dofile = dofile_2a, eval = eval, gensym = compiler.gensym, granulate = parser.granulate, list = utils.list, loadCode = specials["load-code"], macroLoaded = specials["macro-loaded"], makeSearcher = specials["make-searcher"], make_searcher = specials["make-searcher"], mangle = compiler["global-mangling"], metadata = compiler.metadata, parser = parser.parser, path = utils.path, repl = repl, scope = compiler["make-scope"], searchModule = specials["search-module"], searcher = specials["make-searcher"](), stringStream = parser["string-stream"], sym = utils.sym, traceback = compiler.traceback, unmangle = compiler["global-unmangling"], varg = utils.varg, version = "0.7.1-dev"}
utils["fennel-module"] = mod
do
local builtin_macros = [===[;; This module contains all the built-in Fennel macros. Unlike all the other
@@ -2825,6 +3009,9 @@ do
;; The code for these macros is somewhat idiosyncratic because it cannot use any
;; macros which have not yet been defined.
+ ;; TODO: some of these macros modify their arguments; we should stop doing that,
+ ;; but in a way that preserves file/line metadata.
+
(fn -> [val ...]
"Thread-first macro.
Take the first value and splice it into the second form as its first argument.
@@ -2908,6 +3095,45 @@ do
`(let ,closable-bindings ,closer
(close-handlers# (xpcall ,bodyfn ,traceback)))))
+ (fn collect [iter-tbl key-value-expr]
+ "Returns a table made by running an iterator and evaluating an expression
+ that returns key-value pairs to be inserted sequentially into the table.
+ This can be thought of as a \"table comprehension\". The provided key-value
+ expression must return either 2 values, or nil.
+
+ For example,
+ (collect [k v (pairs {:apple \"red\" :orange \"orange\"})]
+ (values v k))
+ returns
+ {:red \"apple\" :orange \"orange\"}"
+ (assert (and (sequence? iter-tbl) (>= (length iter-tbl) 2))
+ "expected iterator binding table")
+ (assert (not= nil key-value-expr)
+ "expected key-value expression")
+ `(let [tbl# {}]
+ (each ,iter-tbl
+ (match ,key-value-expr
+ (k# v#) (tset tbl# k# v#)))
+ tbl#))
+
+ (fn icollect [iter-tbl value-expr]
+ "Returns a sequential table made by running an iterator and evaluating an
+ expression that returns values to be inserted sequentially into the table.
+ This can be thought of as a \"list comprehension\".
+
+ For example,
+ (icollect [_ v (ipairs [1 2 3 4 5])] (when (> v 2) (* v v)))
+ returns
+ [9 16 25]"
+ (assert (and (sequence? iter-tbl) (>= (length iter-tbl) 2))
+ "expected iterator binding table")
+ (assert (not= nil value-expr)
+ "expected table value expression")
+ `(let [tbl# []]
+ (each ,iter-tbl
+ (tset tbl# (+ (length tbl#) 1) ,value-expr))
+ tbl#))
+
(fn partial [f ...]
"Returns a function with all arguments partially applied to f."
(let [body (list f ...)]
@@ -2960,9 +3186,8 @@ do
(if (table? a)
(each [_ a (pairs a)]
(check! a))
- (and (not (string.match (tostring a) "^?"))
- (not= (tostring a) "&")
- (not= (tostring a) "..."))
+ (let [as (tostring a)]
+ (and (not (as:match "^?")) (not= as "&") (not= as "_") (not= as "...")))
(table.insert args arity-check-position
`(assert (not= nil ,a)
(string.format "Missing argument %s on %s:%s"
@@ -2980,7 +3205,7 @@ do
"Define a single macro."
(assert (sym? name) "expected symbol for macro name")
(local args [...])
- `(macros { ,(tostring name) (fn ,name ,(unpack args))}))
+ `(macros { ,(tostring name) (fn ,(unpack args))}))
(fn macrodebug [form return?]
"Print the resulting form after performing macroexpansion.
@@ -2998,32 +3223,63 @@ do
(assert (and binding1 module-name1 (= 0 (% (select :# ...) 2)))
"expected even number of binding/modulename pairs")
(for [i 1 (select :# binding1 module-name1 ...) 2]
- (local (binding modname) (select i binding1 module-name1 ...))
- ;; generate a subscope of current scope, use require-macros
- ;; to bring in macro module. after that, we just copy the
- ;; macros from subscope to scope.
- (local scope (get-scope))
- (local subscope (fennel.scope scope))
- (fennel.compile-string (string.format "(require-macros %q)"
- modname)
- {:scope subscope
- :compiler-env utils.root.options.compiler-env})
- (if (sym? binding)
- ;; bind whole table of macros to table bound to symbol
- (do (tset scope.macros (. binding 1) {})
- (each [k v (pairs subscope.macros)]
- (tset (. scope.macros (. binding 1)) k v)))
+ (let [(binding modname) (select i binding1 module-name1 ...)
+ ;; generate a subscope of current scope, use require-macros
+ ;; to bring in macro module. after that, we just copy the
+ ;; macros from subscope to scope.
+ scope (get-scope)
+ subscope (fennel.scope scope)]
+ (_SPECIALS.require-macros `(require-macros ,modname) subscope {} ast)
+ (if (sym? binding)
+ ;; bind whole table of macros to table bound to symbol
+ (do (tset scope.macros (. binding 1) {})
+ (each [k v (pairs subscope.macros)]
+ (tset (. scope.macros (. binding 1)) k v)))
- ;; 1-level table destructuring for importing individual macros
- (table? binding)
- (each [macro-name [import-key] (pairs binding)]
- (assert (= :function (type (. subscope.macros macro-name)))
- (.. "macro " macro-name " not found in module " modname))
- (tset scope.macros import-key (. subscope.macros macro-name)))))
+ ;; 1-level table destructuring for importing individual macros
+ (table? binding)
+ (each [macro-name [import-key] (pairs binding)]
+ (assert (= :function (type (. subscope.macros macro-name)))
+ (.. "macro " macro-name " not found in module "
+ (tostring modname)))
+ (tset scope.macros import-key (. subscope.macros macro-name))))))
nil)
;;; Pattern matching
+ (fn match-values [vals pattern unifications match-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)))
+
+ (fn match-table [val pattern unifications match-pattern]
+ (let [condition `(and (= (type ,val) :table))
+ bindings []]
+ (each [k pat (pairs pattern)]
+ (if (and (sym? pat) (= "&" (tostring pat)))
+ (do (assert (not (. pattern (+ k 2)))
+ "expected rest argument before last parameter")
+ (table.insert bindings (. pattern (+ k 1)))
+ (table.insert bindings [`(select ,k ((or _G.unpack
+ table.unpack)
+ ,val))]))
+ (and (= :number (type k))
+ (= "&" (tostring (. pattern (- k 1)))))
+ nil ; don't process the pattern right after &; already got it
+ (let [subval `(. ,val ,k)
+ (subcondition subbindings) (match-pattern [subval] pat
+ unifications)]
+ (table.insert condition subcondition)
+ (each [_ b (ipairs subbindings)]
+ (table.insert bindings b)))))
+ (values condition bindings)))
+
(fn match-pattern [vals pattern unifications]
"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
@@ -3040,12 +3296,11 @@ do
(in-scope? (. (multi-sym? pattern) 1))))
(values `(= ,val ,pattern) [])
;; unify a local we've seen already
- (and (sym? pattern)
- (. unifications (tostring pattern)))
+ (and (sym? pattern) (. unifications (tostring pattern)))
(values `(= ,(. unifications (tostring pattern)) ,val) [])
;; bind a fresh local
(sym? pattern)
- (let [wildcard? (= (tostring pattern) "_")]
+ (let [wildcard? (: (tostring pattern) :find "^_")]
(if (not wildcard?) (tset unifications (tostring pattern) val))
(values (if (or wildcard? (string.find (tostring pattern) "^?"))
true `(not= ,(sym :nil) ,val))
@@ -3061,37 +3316,10 @@ do
;; 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))
+ (match-values vals pattern unifications match-pattern)
;; table patterns
(= (type pattern) :table)
- (let [condition `(and (= (type ,val) :table))
- bindings []]
- (each [k pat (pairs pattern)]
- (if (and (sym? pat) (= "&" (tostring pat)))
- (do (assert (not (. pattern (+ k 2)))
- "expected rest argument before last parameter")
- (table.insert bindings (. pattern (+ k 1)))
- (table.insert bindings [`(select ,k ((or _G.unpack
- table.unpack)
- ,val))]))
- (and (= :number (type k))
- (= "&" (tostring (. pattern (- k 1)))))
- nil ; don't process the pattern right after &; already got it
- (let [subval `(. ,val ,k)
- (subcondition subbindings) (match-pattern [subval] pat
- unifications)]
- (table.insert condition subcondition)
- (each [_ b (ipairs subbindings)]
- (table.insert bindings b)))))
- (values condition bindings))
+ (match-table val pattern unifications match-pattern)
;; literal value
(values `(= ,val ,pattern) []))))
@@ -3129,6 +3357,7 @@ do
{: -> : ->> : -?> : -?>>
: doto : when : with-open
+ : collect : icollect
: partial : lambda
: pick-args : pick-values
: macro : macrodebug : import-macros
diff --git a/lib/fennelview.lua b/lib/fennelview.lua
index ecd5660..58b6ec2 100644
--- a/lib/fennelview.lua
+++ b/lib/fennelview.lua
@@ -21,14 +21,18 @@ local function sequence_key_3f(k, len)
return ((type(k) == "number") and (1 <= k) and (k <= len) and (math.floor(k) == k))
end
local type_order = {["function"] = 5, boolean = 2, number = 1, string = 3, table = 4, thread = 7, userdata = 6}
-local function sort_keys(a, b)
+local function sort_keys(_0_0, _1_0)
+ local _1_ = _0_0
+ local a = _1_[1]
+ local _2_ = _1_0
+ local b = _2_[1]
local ta = type(a)
local tb = type(b)
- if ((ta == tb) and (ta ~= "boolean") and ((ta == "string") or (ta == "number"))) then
+ if ((ta == tb) and ((ta == "string") or (ta == "number"))) then
return (a < b)
else
- local dta = type_order[a]
- local dtb = type_order[b]
+ local dta = type_order[ta]
+ local dtb = type_order[tb]
if (dta and dtb) then
return (dta < dtb)
elseif dta then
@@ -41,7 +45,7 @@ local function sort_keys(a, b)
end
end
local function get_sequence_length(t)
- local len = 1
+ local len = 0
for i in ipairs(t) do
len = i
end
@@ -50,9 +54,9 @@ end
local function get_nonsequential_keys(t)
local keys = {}
local sequence_length = get_sequence_length(t)
- for k in pairs(t) do
+ for k, v in pairs(t) do
if not sequence_key_3f(k, sequence_length) then
- table.insert(keys, k)
+ table.insert(keys, {k, v})
end
end
table.sort(keys, sort_keys)
@@ -66,9 +70,7 @@ local function count_table_appearances(t, appearances)
count_table_appearances(k, appearances)
count_table_appearances(v, appearances)
end
- end
- else
- if (t and (t == t)) then
+ else
appearances[t] = ((appearances[t] or 0) + 1)
end
end
@@ -100,12 +102,12 @@ end
local function put_sequential_table(self, t, len)
puts(self, "[")
self.level = (self.level + 1)
- for i = 1, len do
- local _0_ = (1 + len)
- if ((1 < i) and (i < _0_)) then
+ for k, v in ipairs(t) do
+ local _2_ = (1 + len)
+ if ((1 < k) and (k < _2_)) then
puts(self, " ")
end
- put_value(self, t[i])
+ put_value(self, v)
end
self.level = (self.level - 1)
return puts(self, "]")
@@ -120,13 +122,16 @@ end
local function put_kv_table(self, t, ordered_keys)
puts(self, "{")
self.level = (self.level + 1)
- for i, k in ipairs(ordered_keys) do
+ for i, _2_0 in ipairs(ordered_keys) do
+ local _3_ = _2_0
+ local k = _3_[1]
+ local v = _3_[2]
if (self["table-edges"] or (i ~= 1)) then
tabify(self)
end
put_key(self, k)
puts(self, " ")
- put_value(self, t[k])
+ put_value(self, v)
end
for i, v in ipairs(t) do
tabify(self)
@@ -142,22 +147,22 @@ local function put_kv_table(self, t, ordered_keys)
end
local function put_table(self, t)
local metamethod = nil
- local function _1_()
- local _0_0 = t
- if _0_0 then
- local _2_0 = getmetatable(_0_0)
- if _2_0 then
- return _2_0.__fennelview
+ local function _3_()
+ local _2_0 = t
+ if _2_0 then
+ local _4_0 = getmetatable(_2_0)
+ if _4_0 then
+ return _4_0.__fennelview
else
- return _2_0
+ return _4_0
end
else
- return _0_0
+ return _2_0
end
end
- metamethod = (self["metamethod?"] and _1_())
+ metamethod = (self["metamethod?"] and _3_())
if (already_visited_3f(self, t) and self["detect-cycles?"]) then
- return puts(self, "#")
+ return puts(self, "#")
elseif (self.level >= self.depth) then
return puts(self, "{...}")
elseif metamethod then
@@ -166,16 +171,17 @@ local function put_table(self, t)
local non_seq_keys, len = get_nonsequential_keys(t)
local id = get_id(self, t)
if ((1 < (self.appearances[t] or 0)) and self["detect-cycles?"]) then
- return puts(self, "#")
- elseif ((#non_seq_keys == 0) and (#t == 0)) then
- local function _2_()
+ puts(self, "@", id)
+ end
+ if ((#non_seq_keys == 0) and (#t == 0)) then
+ local function _5_()
if self["empty-as-square"] then
return "[]"
else
return "{}"
end
end
- return puts(self, _2_())
+ return puts(self, _5_())
elseif (#non_seq_keys == 0) then
return put_sequential_table(self, t, len)
elseif "else" then
@@ -183,19 +189,30 @@ local function put_table(self, t)
end
end
end
-local function _0_(self, v)
+local function _2_(self, v)
local tv = type(v)
if (tv == "string") then
return puts(self, view_quote(escape(v)))
elseif ((tv == "number") or (tv == "boolean") or (tv == "nil")) then
return puts(self, tostring(v))
- elseif (tv == "table") then
- return put_table(self, v)
- elseif "else" then
- return puts(self, "#<", tostring(v), ">")
+ else
+ local _4_
+ do
+ local _3_0 = getmetatable(v)
+ if _3_0 then
+ _4_ = _3_0.__fennelview
+ else
+ _4_ = _3_0
+ end
+ end
+ if ((tv == "table") or ((tv == "userdata") and (nil ~= _4_))) then
+ return put_table(self, v)
+ elseif "else" then
+ return puts(self, "#<", tostring(v), ">")
+ end
end
end
-put_value = _0_
+put_value = _2_
local function one_line(str)
local ret = str:gsub("\n", " "):gsub("%[ ", "["):gsub(" %]", "]"):gsub("%{ ", "{"):gsub(" %}", "}"):gsub("%( ", "("):gsub(" %)", ")")
return ret
@@ -203,17 +220,17 @@ end
local function fennelview(x, options)
local options0 = (options or {})
local inspector = nil
- local function _1_(_241)
+ local function _3_(_241)
return fennelview(_241, options0)
end
- local function _2_()
+ local function _4_()
if options0["one-line"] then
return ""
else
return " "
end
end
- inspector = {["detect-cycles?"] = not (false == options0["detect-cycles?"]), ["empty-as-square"] = options0["empty-as-square"], ["max-ids"] = {}, ["metamethod?"] = not (false == options0["metamethod?"]), ["table-edges"] = (options0["table-edges"] ~= false), appearances = count_table_appearances(x, {}), buffer = {}, depth = (options0.depth or 128), fennelview = _1_, ids = {}, indent = (options0.indent or _2_()), level = 0}
+ inspector = {["detect-cycles?"] = not (false == options0["detect-cycles?"]), ["empty-as-square"] = options0["empty-as-square"], ["max-ids"] = {}, ["metamethod?"] = not (false == options0["metamethod?"]), ["table-edges"] = (options0["table-edges"] ~= false), appearances = count_table_appearances(x, {}), buffer = {}, depth = (options0.depth or 128), fennelview = _3_, ids = {}, indent = (options0.indent or _4_()), level = 0}
put_value(inspector, x)
local str = table.concat(inspector.buffer)
if options0["one-line"] then