@@ 6,34 6,34 @@ package.preload["fnlfmt"] = package.preload["fnlfmt"] or function(...)
return #line:match("[^\n]*$")
end
local function any_3f(tbl, pred)
- local _0_
+ local _276_
do
- local tbl_0_ = {}
+ local tbl_12_auto = {}
for _, v in pairs(tbl) do
- local _1_
+ local _277_
if pred(v) then
- _1_ = true
+ _277_ = true
else
- _1_ = nil
+ _277_ = nil
end
- tbl_0_[(#tbl_0_ + 1)] = _1_
+ tbl_12_auto[(#tbl_12_auto + 1)] = _277_
end
- _0_ = tbl_0_
+ _276_ = tbl_12_auto
end
- return (0 ~= #_0_)
+ return (0 ~= #_276_)
end
local function strip_comments(t)
- local tbl_0_ = {}
+ local tbl_12_auto = {}
for _, x in ipairs(t) do
- local _0_
+ local _279_
if not fennel["comment?"](x) then
- _0_ = x
+ _279_ = x
else
- _0_ = nil
+ _279_ = nil
end
- tbl_0_[(#tbl_0_ + 1)] = _0_
+ tbl_12_auto[(#tbl_12_auto + 1)] = _279_
end
- return tbl_0_
+ return tbl_12_auto
end
local function view_fn_args(t, view, inspector, indent, start_indent, out, callee)
if fennel["sym?"](t[2]) then
@@ 106,13 106,13 @@ package.preload["fnlfmt"] = package.preload["fnlfmt"] or function(...)
else
table.insert(out, " ")
end
- local indent = nil
+ local indent
if force_initial_newline[callee] then
indent = start_indent
else
indent = (start_indent + #callee)
end
- local second = nil
+ local second
if (init_bindings[callee] and ("unquote" ~= tostring(t[2][1]))) then
second = view_binding(t[2], view, inspector, (indent + 1), ("let" == callee), "[", "]")
else
@@ 140,7 140,7 @@ package.preload["fnlfmt"] = package.preload["fnlfmt"] or function(...)
end
local function view_body(t, view, inspector, start_indent, out, callee)
local start_index = view_init_body(t, view, inspector, start_indent, out, callee)
- local indent = nil
+ local indent
if one_element_per_line_forms[callee] then
indent = (start_indent + #callee)
else
@@ 193,14 193,13 @@ package.preload["fnlfmt"] = package.preload["fnlfmt"] or function(...)
return table.insert(out, (" " .. view_binding({select(2, unpack(t))}, view, inspector, indent, true, "", "")))
end
local function if_pair(view, a, b, c)
- local function _0_()
- if fennel["comment?"](c) then
- return (" " .. view(c))
- else
- return ""
- end
+ local _298_
+ if fennel["comment?"](c) then
+ _298_ = (" " .. view(c))
+ else
+ _298_ = ""
end
- return (view(a) .. " " .. view(b) .. _0_())
+ return (view(a) .. " " .. view(b) .. _298_)
end
local function pairwise_if_3f(t, indent, i, view)
if (#strip_comments(t) < 5) then
@@ 212,21 211,21 @@ package.preload["fnlfmt"] = package.preload["fnlfmt"] or function(...)
elseif (80 < (indent + 1 + #if_pair(view, select(i, unpack(t))))) then
return false
else
- local _0_
+ local _300_
if fennel.comment(t[(i + 2)]) then
- _0_ = (i + 3)
+ _300_ = (i + 3)
else
- _0_ = (i + 2)
+ _300_ = (i + 2)
end
- return pairwise_if_3f(t, indent, _0_, view)
+ return pairwise_if_3f(t, indent, _300_, view)
end
end
- local function originally_different_lines_3f(_0_0, line)
- local _arg_0_ = _0_0
- local _ = _arg_0_[1]
- local first = _arg_0_[2]
- local second = _arg_0_[3]
- return (("table" == type(first)) and ("table" == type(second)) and (function(_1_,_2_,_3_) return (_1_ ~= _2_) or (_2_ ~= _3_) end)(line,(first.line or line),(second.line or line)))
+ local function originally_different_lines_3f(_303_, line)
+ local _arg_304_ = _303_
+ local _ = _arg_304_[1]
+ local first = _arg_304_[2]
+ local second = _arg_304_[3]
+ return (("table" == type(first)) and ("table" == type(second)) and (function(_305_,_306_,_307_) return (_305_ ~= _306_) or (_306_ ~= _307_) end)(line,(first.line or line),(second.line or line)))
end
local function view_maybe_body(t, view, inspector, indent, start_indent, out, callee)
if pairwise_if_3f(t, indent, 2, view) then
@@ 256,7 255,7 @@ package.preload["fnlfmt"] = package.preload["fnlfmt"] or function(...)
local callee = view(t[1], inspector, (start_indent + 1))
local callee0 = (renames[callee] or callee)
local out = {"(", callee0}
- local indent = nil
+ local indent
if body_specials[callee0] then
indent = (start_indent + 2)
else
@@ 274,20 273,19 @@ package.preload["fnlfmt"] = package.preload["fnlfmt"] or function(...)
return table.concat(out)
end
end
- local slength = nil
- local _2_
- do
- local _1_0 = rawget(_G, "utf8")
- if _1_0 then
- _2_ = (_1_0).len
+ local slength
+ local function _314_(...)
+ local _313_ = rawget(_G, "utf8")
+ if _313_ then
+ return (_313_).len
else
- _2_ = _1_0
+ return _313_
end
end
- local function _3_(_241)
+ local function _316_(_241)
return #_241
end
- slength = (_2_ or _3_)
+ slength = (_314_(...) or _316_)
local function maybe_attach_comment(x, indent, c)
if c then
return (tostring(c) .. "\n" .. string.rep(" ", indent) .. x)
@@ 300,49 298,51 @@ package.preload["fnlfmt"] = package.preload["fnlfmt"] or function(...)
end
local function view_pair(t, view, inspector, indent, mt, key)
local val = t[key]
- local k = nil
+ local k
if shorthand_pair_3f(key, val) then
k = ":"
else
k = view(key, inspector, (indent + 1), true)
end
local v = view(val, inspector, (indent + slength(k) + 1))
- local function _5_()
- local res_0_ = mt.comments
- local function _6_()
- local res_0_0 = (res_0_).keys
- local function _7_()
- local res_0_1 = (res_0_0)[key]
- return (res_0_1 and res_0_1)
- end
- return (res_0_0 and _7_())
+ local function _320_()
+ local t_319_ = mt
+ if (nil ~= t_319_) then
+ t_319_ = (t_319_).comments
+ end
+ if (nil ~= t_319_) then
+ t_319_ = (t_319_).keys
end
- return (res_0_ and _6_())
+ if (nil ~= t_319_) then
+ t_319_ = (t_319_)[key]
+ end
+ return t_319_
end
- local function _6_()
- local res_0_ = mt.comments
- local function _7_()
- local res_0_0 = (res_0_).values
- local function _8_()
- local res_0_1 = (res_0_0)[val]
- return (res_0_1 and res_0_1)
- end
- return (res_0_0 and _8_())
+ local function _325_()
+ local t_324_ = mt
+ if (nil ~= t_324_) then
+ t_324_ = (t_324_).comments
+ end
+ if (nil ~= t_324_) then
+ t_324_ = (t_324_).values
end
- return (res_0_ and _7_())
+ if (nil ~= t_324_) then
+ t_324_ = (t_324_)[val]
+ end
+ return t_324_
end
- return (maybe_attach_comment(k, indent, _5_()) .. " " .. maybe_attach_comment(v, indent, _6_()))
+ return (maybe_attach_comment(k, indent, _320_()) .. " " .. maybe_attach_comment(v, indent, _325_()))
end
local function view_multiline_kv(pair_strs, indent, last_comment)
if last_comment then
- local _5_
+ local _330_
do
- local _4_0 = pair_strs
- table.insert(_4_0, tostring(last_comment))
- table.insert(_4_0, "}")
- _5_ = _4_0
+ local _329_ = pair_strs
+ table.insert(_329_, tostring(last_comment))
+ table.insert(_329_, "}")
+ _330_ = _329_
end
- return ("{" .. table.concat(_5_, ("\n" .. string.rep(" ", indent))))
+ return ("{" .. table.concat(_330_, ("\n" .. string.rep(" ", indent))))
else
return ("{" .. table.concat(pair_strs, ("\n" .. string.rep(" ", indent))) .. "}")
end
@@ 350,43 350,46 @@ package.preload["fnlfmt"] = package.preload["fnlfmt"] or function(...)
local function view_kv(t, view, inspector, indent)
local indent0 = (indent + 1)
local mt = getmetatable(t)
- local keys = nil
- local function _4_()
- local tbl_0_ = {}
+ local keys
+ local function _332_()
+ local tbl_12_auto = {}
for k in pairs(t) do
- tbl_0_[(#tbl_0_ + 1)] = k
+ tbl_12_auto[(#tbl_12_auto + 1)] = k
end
- return tbl_0_
+ return tbl_12_auto
end
- keys = (mt.keys or _4_())
- local pair_strs = nil
+ keys = (mt.keys or _332_())
+ local pair_strs
do
- local tbl_0_ = {}
+ local tbl_12_auto = {}
for _, k in ipairs(keys) do
- tbl_0_[(#tbl_0_ + 1)] = view_pair(t, view, inspector, indent0, mt, k)
+ tbl_12_auto[(#tbl_12_auto + 1)] = view_pair(t, view, inspector, indent0, mt, k)
end
- pair_strs = tbl_0_
+ pair_strs = tbl_12_auto
end
local oneline = ("{" .. table.concat(pair_strs, " ") .. "}")
- local _5_
- do
- local res_0_ = mt.comments
- local function _6_()
- local res_0_0 = (res_0_).last
- return (res_0_0 and res_0_0)
+ local function _334_()
+ local t_333_ = mt
+ if (nil ~= t_333_) then
+ t_333_ = (t_333_).comments
+ end
+ if (nil ~= t_333_) then
+ t_333_ = (t_333_).last
end
- _5_ = (res_0_ and _6_())
+ return t_333_
end
- if (oneline:match("\n") or _5_ or ((indent0 + #oneline) > inspector["line-length"])) then
- local function _6_()
- local res_0_ = mt.comments
- local function _7_()
- local res_0_0 = (res_0_).last
- return (res_0_0 and res_0_0)
+ if (oneline:match("\n") or _334_() or ((indent0 + #oneline) > inspector["line-length"])) then
+ local function _338_()
+ local t_337_ = mt
+ if (nil ~= t_337_) then
+ t_337_ = (t_337_).comments
end
- return (res_0_ and _7_())
+ if (nil ~= t_337_) then
+ t_337_ = (t_337_).last
+ end
+ return t_337_
end
- return view_multiline_kv(pair_strs, indent0, _6_())
+ return view_multiline_kv(pair_strs, indent0, _338_())
else
return oneline
end
@@ 406,12 409,12 @@ package.preload["fnlfmt"] = package.preload["fnlfmt"] or function(...)
local function set_fennelview_metamethod(idx, form, parent)
if (("table" == type(form)) and not fennel["sym?"](form) and not fennel["comment?"](form) and (fennel.varg() ~= form)) then
if (not fennel["list?"](form) and not fennel["sequence?"](form)) then
- local _4_0 = getmetatable(form)
- if (nil ~= _4_0) then
- local mt = _4_0
+ local _343_ = getmetatable(form)
+ if (nil ~= _343_) then
+ local mt = _343_
mt["__fennelview"] = view_kv
else
- local _ = _4_0
+ local _ = _343_
setmetatable(form, {__fennelview = view_kv})
end
end
@@ 422,10 425,10 @@ package.preload["fnlfmt"] = package.preload["fnlfmt"] or function(...)
return (s:find("^[-%w?^_!$%&*+./@|<=>]+$") and not s:find("^[-?^_!$%&*+./@|<=>%\\]+$"))
end
local function fnlfmt(ast)
- local _let_0_ = getmetatable(fennel.list())
- local list_mt = _let_0_
- local __fennelview = _let_0_["__fennelview"]
- local _ = nil
+ local _let_347_ = getmetatable(fennel.list())
+ local list_mt = _let_347_
+ local __fennelview = _let_347_["__fennelview"]
+ local _
list_mt.__fennelview = view_list
_ = nil
local _0 = walk_tree(ast, set_fennelview_metamethod)
@@ 437,16 440,16 @@ package.preload["fnlfmt"] = package.preload["fnlfmt"] or function(...)
local function space_out_forms_3f(prev_ast, ast)
return not (prev_ast.line and ast.line and (1 == (ast.line - prev_ast.line)))
end
- local function format_file(filename, _4_0)
- local _arg_0_ = _4_0
- local no_comments = _arg_0_["no-comments"]
- local f = nil
+ local function format_file(filename, _348_)
+ local _arg_349_ = _348_
+ local no_comments = _arg_349_["no-comments"]
+ local f
do
- local _5_0 = filename
- if (_5_0 == "-") then
+ local _350_ = filename
+ if (_350_ == "-") then
f = io.stdin
else
- local _ = _5_0
+ local _ = _350_
f = assert(io.open(filename, "r"), "File not found.")
end
end
@@ 510,17 513,19 @@ package.preload["letter"] = package.preload["letter"] or function(...)
local function transform_do(node)
local bindings = {}
table.insert(node, 2, bindings)
- node[1] = fennel.sym("let")
+ do end (node)[1] = fennel.sym("let")
return locals_to_bindings(node, bindings)
end
- local function transform_fn(node)
+ local function body_start(node)
local has_name_3f = fennel["sym?"](node[2])
- local do_loc = nil
if has_name_3f then
- do_loc = 4
+ return 4
else
- do_loc = 3
+ return 3
end
+ end
+ local function transform_fn(node)
+ local do_loc = body_start(node)
local do_node = fennel.list(fennel.sym("do"))
move_body(node, do_node, do_loc)
return table.insert(node, do_loc, do_node)
@@ 529,15 534,19 @@ package.preload["letter"] = package.preload["letter"] or function(...)
return (("table" == type(node)) and ("do" == tostring(node[1])) and ("table" == type(node[2])) and ("local" == tostring(node[2][1])))
end
local function fn_local_node_3f(node)
- return (("table" == type(node)) and ("fn" == tostring(node[1])) and ((("table" == type(node[3])) and ("local" == tostring(node[3][1]))) or (("table" == type(node[4])) and ("local" == tostring(node[4][1])))))
+ local function _272_()
+ local first_body = node[body_start(node)]
+ return (("table" == type(first_body)) and ("local" == tostring(first_body[1])))
+ end
+ return (("table" == type(node)) and ("fn" == tostring(node[1])) and _272_())
end
local function letter(idx, node)
- if do_local_node_3f(node) then
- transform_do(node)
- end
if fn_local_node_3f(node) then
transform_fn(node)
end
+ if do_local_node_3f(node) then
+ transform_do(node)
+ end
return ("table" == type(node))
end
local function reverse_ipairs(t)
@@ 556,12 565,12 @@ package.preload["letter"] = package.preload["letter"] or function(...)
return compile
end
package.preload["anticompiler"] = package.preload["anticompiler"] or function(...)
- local _local_0_ = require("fennel")
- local list = _local_0_["list"]
- local sequence = _local_0_["sequence"]
- local sym = _local_0_["sym"]
- local sym_3f = _local_0_["sym?"]
- local view = _local_0_["view"]
+ local _local_116_ = require("fennel")
+ local list = _local_116_["list"]
+ local sequence = _local_116_["sequence"]
+ local sym = _local_116_["sym"]
+ local sym_3f = _local_116_["sym?"]
+ local view = _local_116_["view"]
local unpack = (table.unpack or _G.unpack)
local function map(tbl, f, with_last_3f)
local len = #tbl
@@ 583,91 592,112 @@ package.preload["anticompiler"] = package.preload["anticompiler"] or function(..
end
return nil
end
- local function _function(compile, scope, _0_0)
- local _arg_0_ = _0_0
- local body = _arg_0_["body"]
- local params = _arg_0_["params"]
- local vararg = _arg_0_["vararg"]
- local params0 = nil
- local function _1_(...)
- return compile(scope, ...)
- end
- params0 = map(params, _1_)
- local subscope = nil
+ local function _function(compile, scope, _117_)
+ local _arg_118_ = _117_
+ local body = _arg_118_["body"]
+ local params = _arg_118_["params"]
+ local vararg = _arg_118_["vararg"]
+ local params0
+ local function _120_()
+ local _119_ = scope
+ local function _121_(...)
+ return compile(_119_, ...)
+ end
+ return _121_
+ end
+ params0 = map(params, _120_())
+ local subscope
do
- local _2_0 = make_scope(scope)
- add_to_scope(_2_0, "param", params0)
- subscope = _2_0
+ local _122_ = make_scope(scope)
+ add_to_scope(_122_, "param", params0)
+ subscope = _122_
end
- local function _3_(...)
- return compile(subscope, ...)
+ local _124_
+ do
+ local _123_ = subscope
+ local function _125_(...)
+ return compile(_123_, ...)
+ end
+ _124_ = _125_
end
- return list(sym("fn"), sequence(unpack(params0)), unpack(map(body, _3_, true)))
+ return list(sym("fn"), sequence(unpack(params0)), unpack(map(body, _124_, true)))
end
local function declare_function(compile, scope, ast)
if (ast.locald or ("MemberExpression" == ast.id.kind)) then
- local _1_0 = _function(compile, scope, ast)
- table.insert(_1_0, 2, compile(scope, ast.id))
- return _1_0
+ local _126_ = _function(compile, scope, ast)
+ table.insert(_126_, 2, compile(scope, ast.id))
+ return _126_
else
return list(sym("set-forcibly!"), compile(scope, ast.id), _function(compile, scope, ast))
end
end
- local function local_declaration(compile, scope, _1_0)
- local _arg_0_ = _1_0
- local expressions = _arg_0_["expressions"]
- local names = _arg_0_["names"]
- if ((function(_2_,_3_,_4_) return (_2_ == _3_) and (_3_ == _4_) end)(#expressions,#names,1) and ("FunctionExpression" == expressions[1].kind)) then
+ local function local_declaration(compile, scope, _128_)
+ local _arg_129_ = _128_
+ local expressions = _arg_129_["expressions"]
+ local names = _arg_129_["names"]
+ if ((function(_130_,_131_,_132_) return (_130_ == _131_) and (_131_ == _132_) end)(#expressions,#names,1) and ("FunctionExpression" == expressions[1].kind)) then
add_to_scope(scope, "function", {names[1].name})
- local function _6_()
- local _5_0 = expressions[1]
- _5_0["id"] = names[1]
- _5_0["locald"] = true
- return _5_0
+ local function _134_()
+ local _133_ = expressions[1]
+ _133_["id"] = names[1]
+ _133_["locald"] = true
+ return _133_
end
- return declare_function(compile, scope, _6_())
+ return declare_function(compile, scope, _134_())
else
local local_sym = sym("local")
- local function _5_(_241)
+ local function _135_(_241)
return _241.name
end
- add_to_scope(scope, "local", map(names, _5_), local_sym)
- local _6_
+ add_to_scope(scope, "local", map(names, _135_), local_sym)
+ local _136_
if (1 == #names) then
- _6_ = sym(names[1].name)
+ _136_ = sym(names[1].name)
else
- local function _7_(...)
- return compile(scope, ...)
+ local function _138_()
+ local _137_ = scope
+ local function _139_(...)
+ return compile(_137_, ...)
+ end
+ return _139_
end
- _6_ = list(unpack(map(names, _7_)))
+ _136_ = list(unpack(map(names, _138_())))
end
- local function _8_()
+ local function _144_()
if (1 == #expressions) then
return compile(scope, expressions[1])
elseif (0 == #expressions) then
return sym("nil")
else
- local function _8_(...)
- return compile(scope, ...)
+ local function _142_()
+ local _141_ = scope
+ local function _143_(...)
+ return compile(_141_, ...)
+ end
+ return _143_
end
- return list(sym("values"), unpack(map(expressions, _8_)))
+ return list(sym("values"), unpack(map(expressions, _142_())))
end
end
- return list(local_sym, _6_, _8_())
+ return list(local_sym, _136_, _144_())
end
end
- local function vals(compile, scope, _2_0)
- local _arg_0_ = _2_0
- local arguments = _arg_0_["arguments"]
+ local function vals(compile, scope, _146_)
+ local _arg_147_ = _146_
+ local arguments = _arg_147_["arguments"]
if (1 == #arguments) then
return compile(scope, arguments[1])
elseif (0 == #arguments) then
return sym("nil")
else
- local function _3_(...)
- return compile(scope, ...)
+ local function _149_()
+ local _148_ = scope
+ local function _150_(...)
+ return compile(_148_, ...)
+ end
+ return _150_
end
- return list(sym("values"), unpack(map(arguments, _3_)))
+ return list(sym("values"), unpack(map(arguments, _149_())))
end
end
local function any_complex_expressions_3f(args, i)
@@ 690,54 720,66 @@ package.preload["anticompiler"] = package.preload["anticompiler"] or function(..
end
return list(sym("let"), bindings, list(sym("lua"), ("return " .. table.concat(binding_names, ", "))))
end
- local function early_return(compile, scope, _3_0)
- local _arg_0_ = _3_0
- local arguments = _arg_0_["arguments"]
- local args = nil
- local function _4_(...)
- return compile(scope, ...)
+ local function early_return(compile, scope, _153_)
+ local _arg_154_ = _153_
+ local arguments = _arg_154_["arguments"]
+ local args
+ local function _156_()
+ local _155_ = scope
+ local function _157_(...)
+ return compile(_155_, ...)
+ end
+ return _157_
end
- args = map(arguments, _4_)
+ args = map(arguments, _156_())
if any_complex_expressions_3f(arguments, 1) then
return early_return_complex(compile, scope, args)
else
return list(sym("lua"), ("return " .. table.concat(map(args, view), ", ")))
end
end
- local function binary(compile, scope, _4_0, ast)
- local _arg_0_ = _4_0
- local left = _arg_0_["left"]
- local operator = _arg_0_["operator"]
- local right = _arg_0_["right"]
+ local function binary(compile, scope, _159_, ast)
+ local _arg_160_ = _159_
+ local left = _arg_160_["left"]
+ local operator = _arg_160_["operator"]
+ local right = _arg_160_["right"]
local operators = {["#"] = "length", ["=="] = "=", ["~"] = "bnot", ["~="] = "not="}
return list(sym((operators[operator] or operator)), compile(scope, left), compile(scope, right))
end
- local function unary(compile, scope, _5_0, ast)
- local _arg_0_ = _5_0
- local argument = _arg_0_["argument"]
- local operator = _arg_0_["operator"]
+ local function unary(compile, scope, _161_, ast)
+ local _arg_162_ = _161_
+ local argument = _arg_162_["argument"]
+ local operator = _arg_162_["operator"]
return list(sym(operator), compile(scope, argument))
end
- local function call(compile, scope, _6_0)
- local _arg_0_ = _6_0
- local arguments = _arg_0_["arguments"]
- local callee = _arg_0_["callee"]
- local function _7_(...)
- return compile(scope, ...)
+ local function call(compile, scope, _163_)
+ local _arg_164_ = _163_
+ local arguments = _arg_164_["arguments"]
+ local callee = _arg_164_["callee"]
+ local function _166_()
+ local _165_ = scope
+ local function _167_(...)
+ return compile(_165_, ...)
+ end
+ return _167_
end
- return list(compile(scope, callee), unpack(map(arguments, _7_)))
+ return list(compile(scope, callee), unpack(map(arguments, _166_())))
end
- local function send(compile, scope, _7_0)
- local _arg_0_ = _7_0
- local arguments = _arg_0_["arguments"]
- local method = _arg_0_["method"]
- local receiver = _arg_0_["receiver"]
+ local function send(compile, scope, _168_)
+ local _arg_169_ = _168_
+ local arguments = _arg_169_["arguments"]
+ local method = _arg_169_["method"]
+ local receiver = _arg_169_["receiver"]
local target = compile(scope, receiver)
- local args = nil
- local function _8_(...)
- return compile(scope, ...)
+ local args
+ local function _171_()
+ local _170_ = scope
+ local function _172_(...)
+ return compile(_170_, ...)
+ end
+ return _172_
end
- args = map(arguments, _8_)
+ args = map(arguments, _171_())
if sym_3f(target) then
return list(sym((tostring(target) .. ":" .. method.name)), unpack(args))
else
@@ 745,34 787,34 @@ package.preload["anticompiler"] = package.preload["anticompiler"] or function(..
end
end
local function any_computed_3f(ast)
- local function _8_()
+ local function _174_()
if (ast.object.kind == "MemberExpression") then
return any_computed_3f(ast.object)
else
return true
end
end
- return (ast.computed or (ast.object and (ast.object.kind ~= "Identifier") and _8_()))
+ return (ast.computed or (ast.object and (ast.object.kind ~= "Identifier") and _174_()))
end
local function member(compile, scope, ast)
if any_computed_3f(ast) then
- local function _8_()
+ local function _175_()
if ast.computed then
return compile(scope, ast.property)
else
return view(compile(scope, ast.property))
end
end
- return list(sym("."), compile(scope, ast.object), _8_())
+ return list(sym("."), compile(scope, ast.object), _175_())
else
return sym((tostring(compile(scope, ast.object)) .. "." .. ast.property.name))
end
end
- local function if_2a(compile, scope, _8_0, tail_3f)
- local _arg_0_ = _8_0
- local alternate = _arg_0_["alternate"]
- local cons = _arg_0_["cons"]
- local tests = _arg_0_["tests"]
+ local function if_2a(compile, scope, _177_, tail_3f)
+ local _arg_178_ = _177_
+ local alternate = _arg_178_["alternate"]
+ local cons = _arg_178_["cons"]
+ local tests = _arg_178_["tests"]
for _, v in ipairs(cons) do
if (0 == #v) then
table.insert(v, sym("nil"))
@@ 780,211 822,265 @@ package.preload["anticompiler"] = package.preload["anticompiler"] or function(..
end
local subscope = make_scope(scope)
if (not alternate and (1 == #tests)) then
- local function _9_(...)
- return compile(subscope, ...)
+ local _181_
+ do
+ local _180_ = subscope
+ local function _182_(...)
+ return compile(_180_, ...)
+ end
+ _181_ = _182_
end
- return list(sym("when"), compile(scope, tests[1]), unpack(map(cons[1], _9_, tail_3f)))
+ return list(sym("when"), compile(scope, tests[1]), unpack(map(cons[1], _181_, tail_3f)))
else
local out = list(sym("if"))
for i, test in ipairs(tests) do
table.insert(out, compile(scope, test))
local c = cons[i]
- local function _9_()
+ local function _186_()
if (1 == #c) then
return compile(subscope, c[1], tail_3f)
else
- local function _9_(...)
- return compile(subscope, ...)
+ local _184_
+ do
+ local _183_ = subscope
+ local function _185_(...)
+ return compile(_183_, ...)
+ end
+ _184_ = _185_
end
- return list(sym("do"), unpack(map(c, _9_, tail_3f)))
+ return list(sym("do"), unpack(map(c, _184_, tail_3f)))
end
end
- table.insert(out, _9_())
+ table.insert(out, _186_())
end
if alternate then
- local function _9_()
+ local function _190_()
if (1 == #alternate) then
return compile(subscope, alternate[1], tail_3f)
else
- local function _9_(...)
- return compile(subscope, ...)
+ local _188_
+ do
+ local _187_ = subscope
+ local function _189_(...)
+ return compile(_187_, ...)
+ end
+ _188_ = _189_
end
- return list(sym("do"), unpack(map(alternate, _9_, tail_3f)))
+ return list(sym("do"), unpack(map(alternate, _188_, tail_3f)))
end
end
- table.insert(out, _9_())
+ table.insert(out, _190_())
end
return out
end
end
- local function concat(compile, scope, _9_0)
- local _arg_0_ = _9_0
- local terms = _arg_0_["terms"]
- local function _10_(...)
- return compile(scope, ...)
+ local function concat(compile, scope, _193_)
+ local _arg_194_ = _193_
+ local terms = _arg_194_["terms"]
+ local function _196_()
+ local _195_ = scope
+ local function _197_(...)
+ return compile(_195_, ...)
+ end
+ return _197_
end
- return list(sym(".."), unpack(map(terms, _10_)))
+ return list(sym(".."), unpack(map(terms, _196_())))
end
- local function each_2a(compile, scope, _10_0)
- local _arg_0_ = _10_0
- local body = _arg_0_["body"]
- local explist = _arg_0_["explist"]
- local namelist = _arg_0_["namelist"]
+ local function each_2a(compile, scope, _198_)
+ local _arg_199_ = _198_
+ local body = _arg_199_["body"]
+ local explist = _arg_199_["explist"]
+ local namelist = _arg_199_["namelist"]
local subscope = make_scope(scope)
- local binding = nil
- local function _11_(...)
- return compile(scope, ...)
+ local binding
+ local function _201_()
+ local _200_ = scope
+ local function _202_(...)
+ return compile(_200_, ...)
+ end
+ return _202_
end
- binding = map(namelist.names, _11_)
+ binding = map(namelist.names, _201_())
add_to_scope(subscope, "param", binding)
- local function _12_(...)
- return compile(scope, ...)
+ local function _204_()
+ local _203_ = scope
+ local function _205_(...)
+ return compile(_203_, ...)
+ end
+ return _205_
end
- for _, form in ipairs(map(explist, _12_)) do
+ for _, form in ipairs(map(explist, _204_())) do
table.insert(binding, form)
end
- local function _12_(...)
- return compile(subscope, ...)
+ local function _207_()
+ local _206_ = subscope
+ local function _208_(...)
+ return compile(_206_, ...)
+ end
+ return _208_
end
- return list(sym("each"), binding, unpack(map(body, _12_)))
+ return list(sym("each"), binding, unpack(map(body, _207_())))
end
local function tset_2a(compile, scope, left, right_out, ast)
if (1 < #left) then
error(("Unsupported form; tset cannot set multiple values on line " .. (ast.line or "?")))
end
- local _12_
+ local _210_
if (not left[1].computed and (left[1].property.kind == "Identifier")) then
- _12_ = left[1].property.name
+ _210_ = left[1].property.name
else
- _12_ = compile(scope, left[1].property)
+ _210_ = compile(scope, left[1].property)
end
- return list(sym("tset"), compile(scope, left[1].object), _12_, right_out)
+ return list(sym("tset"), compile(scope, left[1].object), _210_, right_out)
end
local function varize_local_21(scope, name)
scope[name].ast[1] = "var"
return true
end
local function setter_for(scope, names)
- local kinds = nil
- local function _11_(_241)
- local _12_0 = (scope[_241] or _241)
- if ((type(_12_0) == "table") and (nil ~= (_12_0).kind)) then
- local kind = (_12_0).kind
+ local kinds
+ local function _212_(_241)
+ local _213_ = (scope[_241] or _241)
+ if ((type(_213_) == "table") and (nil ~= (_213_).kind)) then
+ local kind = (_213_).kind
return kind
else
- local _ = _12_0
+ local _ = _213_
return "global"
end
end
- kinds = map(names, _11_)
- local _12_0, _13_0, _14_0 = kinds
- local _15_
- do
- local _ = _12_0
- _15_ = (true and (1 < #kinds))
+ kinds = map(names, _212_)
+ local _215_ = kinds
+ local function _216_()
+ local _ = _215_
+ return (1 < #kinds)
end
- if _15_ then
- local _ = _12_0
+ if (true and _216_()) then
+ local _ = _215_
return "set-forcibly!"
- elseif ((type(_12_0) == "table") and ((_12_0)[1] == "local")) then
- local function _16_(...)
- return varize_local_21(scope, ...)
+ elseif ((type(_215_) == "table") and ((_215_)[1] == "local")) then
+ local function _218_()
+ local _217_ = scope
+ local function _219_(...)
+ return varize_local_21(_217_, ...)
+ end
+ return _219_
end
- map(names, _16_)
+ map(names, _218_())
return "set"
- elseif ((type(_12_0) == "table") and ((_12_0)[1] == "MemberExpression")) then
+ elseif ((type(_215_) == "table") and ((_215_)[1] == "MemberExpression")) then
return "set"
- elseif ((type(_12_0) == "table") and ((_12_0)[1] == "function")) then
+ elseif ((type(_215_) == "table") and ((_215_)[1] == "function")) then
return "set-forcibly!"
- elseif ((type(_12_0) == "table") and ((_12_0)[1] == "param")) then
+ elseif ((type(_215_) == "table") and ((_215_)[1] == "param")) then
return "set-forcibly!"
else
- local _ = _12_0
+ local _ = _215_
return "global"
end
end
local function assignment(compile, scope, ast)
- local _let_0_ = ast
- local left = _let_0_["left"]
- local right = _let_0_["right"]
- local right_out = nil
+ local _let_221_ = ast
+ local left = _let_221_["left"]
+ local right = _let_221_["right"]
+ local right_out
if (1 == #right) then
right_out = compile(scope, right[1])
elseif (0 == #right) then
right_out = sym("nil")
else
- local function _11_(...)
- return compile(scope, ...)
+ local function _223_()
+ local _222_ = scope
+ local function _224_(...)
+ return compile(_222_, ...)
+ end
+ return _224_
end
- right_out = list(sym("values"), unpack(map(right, _11_)))
+ right_out = list(sym("values"), unpack(map(right, _223_())))
end
if any_computed_3f(left[1]) then
return tset_2a(compile, scope, left, right_out, ast)
else
- local setter = nil
- local function _12_(_241)
+ local setter
+ local function _226_(_241)
return (_241.name or _241)
end
- setter = setter_for(scope, map(left, _12_))
- local _13_
+ setter = setter_for(scope, map(left, _226_))
+ local _227_
if (1 == #left) then
- _13_ = compile(scope, left[1])
+ _227_ = compile(scope, left[1])
else
- local function _14_(...)
- return compile(scope, ...)
+ local function _229_()
+ local _228_ = scope
+ local function _230_(...)
+ return compile(_228_, ...)
+ end
+ return _230_
end
- _13_ = list(unpack(map(left, _14_)))
+ _227_ = list(unpack(map(left, _229_())))
end
- return list(sym(setter), _13_, right_out)
+ return list(sym(setter), _227_, right_out)
end
end
- local function while_2a(compile, scope, _11_0)
- local _arg_0_ = _11_0
- local body = _arg_0_["body"]
- local test = _arg_0_["test"]
+ local function while_2a(compile, scope, _233_)
+ local _arg_234_ = _233_
+ local body = _arg_234_["body"]
+ local test = _arg_234_["test"]
local subscope = make_scope(scope)
- local function _12_(...)
- return compile(subscope, ...)
- end
- return list(sym("while"), compile(scope, test), unpack(map(body, _12_)))
- end
- local function repeat_2a(compile, scope, _12_0)
- local _arg_0_ = _12_0
- local body = _arg_0_["body"]
- local test = _arg_0_["test"]
- local function _14_()
- local _13_0 = nil
- local function _14_(...)
- return compile(scope, ...)
- end
- _13_0 = map(body, _14_)
- table.insert(_13_0, list(sym("when"), compile(scope, test), list(sym("lua"), "break")))
- return _13_0
- end
- return list(sym("while"), true, unpack(_14_()))
- end
- local function for_2a(compile, scope, _13_0)
- local _arg_0_ = _13_0
- local body = _arg_0_["body"]
- local init = _arg_0_["init"]
- local last = _arg_0_["last"]
- local step = _arg_0_["step"]
+ local function _236_()
+ local _235_ = subscope
+ local function _237_(...)
+ return compile(_235_, ...)
+ end
+ return _237_
+ end
+ return list(sym("while"), compile(scope, test), unpack(map(body, _236_())))
+ end
+ local function repeat_2a(compile, scope, _238_)
+ local _arg_239_ = _238_
+ local body = _arg_239_["body"]
+ local test = _arg_239_["test"]
+ local function _244_()
+ local _240_
+ local function _242_()
+ local _241_ = scope
+ local function _243_(...)
+ return compile(_241_, ...)
+ end
+ return _243_
+ end
+ _240_ = map(body, _242_())
+ table.insert(_240_, list(sym("when"), compile(scope, test), list(sym("lua"), "break")))
+ return _240_
+ end
+ return list(sym("while"), true, unpack(_244_()))
+ end
+ local function for_2a(compile, scope, _245_)
+ local _arg_246_ = _245_
+ local body = _arg_246_["body"]
+ local init = _arg_246_["init"]
+ local last = _arg_246_["last"]
+ local step = _arg_246_["step"]
local i = compile(scope, init.id)
local subscope = make_scope(scope)
add_to_scope(subscope, "param", {i})
- local function _14_(...)
- return compile(subscope, ...)
+ local function _248_()
+ local _247_ = subscope
+ local function _249_(...)
+ return compile(_247_, ...)
+ end
+ return _249_
end
- return list(sym("for"), {i, compile(scope, init.value), compile(scope, last), (step and (step ~= 1) and compile(scope, step))}, unpack(map(body, _14_)))
+ return list(sym("for"), {i, compile(scope, init.value), compile(scope, last), (step and (step ~= 1) and compile(scope, step))}, unpack(map(body, _248_())))
end
- local function table_2a(compile, scope, _14_0)
- local _arg_0_ = _14_0
- local keyvals = _arg_0_["keyvals"]
+ local function table_2a(compile, scope, _250_)
+ local _arg_251_ = _250_
+ local keyvals = _arg_251_["keyvals"]
local out = {}
- for i, _15_0 in pairs(keyvals) do
- local _each_0_ = _15_0
- local v = _each_0_[1]
- local k = _each_0_[2]
+ for i, _252_ in pairs(keyvals) do
+ local _each_253_ = _252_
+ local v = _each_253_[1]
+ local k = _each_253_[2]
if k then
out[compile(scope, k)] = compile(scope, v)
else
@@ 993,14 1089,19 @@ package.preload["anticompiler"] = package.preload["anticompiler"] or function(..
end
return out
end
- local function do_2a(compile, scope, _15_0, tail_3f)
- local _arg_0_ = _15_0
- local body = _arg_0_["body"]
+ local function do_2a(compile, scope, _255_, tail_3f)
+ local _arg_256_ = _255_
+ local body = _arg_256_["body"]
local subscope = make_scope(scope)
- local function _16_(...)
- return compile(subscope, ...)
+ local _258_
+ do
+ local _257_ = subscope
+ local function _259_(...)
+ return compile(_257_, ...)
+ end
+ _258_ = _259_
end
- return list(sym("do"), unpack(map(body, _16_, tail_3f)))
+ return list(sym("do"), unpack(map(body, _258_, tail_3f)))
end
local function _break(compile, scope, ast)
return list(sym("lua"), "break")
@@ 1015,75 1116,80 @@ package.preload["anticompiler"] = package.preload["anticompiler"] or function(..
if os.getenv("DEBUG") then
print(ast.kind)
end
- local _17_0 = ast.kind
- if (_17_0 == "Chunk") then
+ local _262_ = ast.kind
+ if (_262_ == "Chunk") then
local scope0 = make_scope(nil)
- local function _18_(...)
- return compile(scope0, ...)
+ local _264_
+ do
+ local _263_ = scope0
+ local function _265_(...)
+ return compile(_263_, ...)
+ end
+ _264_ = _265_
end
- return map(ast.body, _18_, true)
- elseif (_17_0 == "LocalDeclaration") then
+ return map(ast.body, _264_, true)
+ elseif (_262_ == "LocalDeclaration") then
return local_declaration(compile, scope, ast)
- elseif (_17_0 == "FunctionDeclaration") then
+ elseif (_262_ == "FunctionDeclaration") then
return declare_function(compile, scope, ast)
- elseif (_17_0 == "FunctionExpression") then
+ elseif (_262_ == "FunctionExpression") then
return _function(compile, scope, ast)
- elseif (_17_0 == "BinaryExpression") then
+ elseif (_262_ == "BinaryExpression") then
return binary(compile, scope, ast)
- elseif (_17_0 == "ConcatenateExpression") then
+ elseif (_262_ == "ConcatenateExpression") then
return concat(compile, scope, ast)
- elseif (_17_0 == "CallExpression") then
+ elseif (_262_ == "CallExpression") then
return call(compile, scope, ast)
- elseif (_17_0 == "LogicalExpression") then
+ elseif (_262_ == "LogicalExpression") then
return binary(compile, scope, ast)
- elseif (_17_0 == "AssignmentExpression") then
+ elseif (_262_ == "AssignmentExpression") then
return assignment(compile, scope, ast)
- elseif (_17_0 == "SendExpression") then
+ elseif (_262_ == "SendExpression") then
return send(compile, scope, ast)
- elseif (_17_0 == "MemberExpression") then
+ elseif (_262_ == "MemberExpression") then
return member(compile, scope, ast)
- elseif (_17_0 == "UnaryExpression") then
+ elseif (_262_ == "UnaryExpression") then
return unary(compile, scope, ast)
- elseif (_17_0 == "ExpressionValue") then
+ elseif (_262_ == "ExpressionValue") then
return compile(scope, ast.value)
- elseif (_17_0 == "ExpressionStatement") then
+ elseif (_262_ == "ExpressionStatement") then
return compile(scope, ast.expression)
- elseif (_17_0 == "IfStatement") then
+ elseif (_262_ == "IfStatement") then
return if_2a(compile, scope, ast, tail_3f)
- elseif (_17_0 == "DoStatement") then
+ elseif (_262_ == "DoStatement") then
return do_2a(compile, scope, ast, tail_3f)
- elseif (_17_0 == "ForInStatement") then
+ elseif (_262_ == "ForInStatement") then
return each_2a(compile, scope, ast)
- elseif (_17_0 == "WhileStatement") then
+ elseif (_262_ == "WhileStatement") then
return while_2a(compile, scope, ast)
- elseif (_17_0 == "RepeatStatement") then
+ elseif (_262_ == "RepeatStatement") then
return repeat_2a(compile, scope, ast)
- elseif (_17_0 == "ForStatement") then
+ elseif (_262_ == "ForStatement") then
return for_2a(compile, scope, ast)
- elseif (_17_0 == "BreakStatement") then
+ elseif (_262_ == "BreakStatement") then
return _break(compile, scope, ast)
- elseif (_17_0 == "ReturnStatement") then
+ elseif (_262_ == "ReturnStatement") then
if tail_3f then
return vals(compile, scope, ast)
else
return early_return(compile, scope, ast)
end
- elseif (_17_0 == "Identifier") then
+ elseif (_262_ == "Identifier") then
return sym(ast.name)
- elseif (_17_0 == "Table") then
+ elseif (_262_ == "Table") then
return table_2a(compile, scope, ast)
- elseif (_17_0 == "Literal") then
+ elseif (_262_ == "Literal") then
if (nil == ast.value) then
return sym("nil")
else
return ast.value
end
- elseif (_17_0 == "Vararg") then
+ elseif (_262_ == "Vararg") then
return sym("...")
- elseif (_17_0 == nil) then
+ elseif (_262_ == nil) then
return sym("nil")
else
- local _ = _17_0
+ local _ = _262_
return unsupported(ast)
end
end
@@ 1340,7 1446,7 @@ package.preload["lang.lua_ast"] = package.preload["lang.lua_ast"] or function(..
local function declare(self, name)
local vars = self.current.vars
local entry = create(name)
- vars[(#vars + 1)] = entry
+ do end (vars)[(#vars + 1)] = entry
return entry
end
local function scope_enter(self)
@@ 1460,7 1566,7 @@ package.preload["lang.parser"] = package.preload["lang.parser"] or function(...)
lex_check(ls, "]")
return v
end
- local function _0_(ast, ls)
+ local function _64_(ast, ls)
local line = ls.linenumber
local kvs = {}
lex_check(ls, "{")
@@ 1475,7 1581,7 @@ package.preload["lang.parser"] = package.preload["lang.parser"] or function(...)
lex_check(ls, "=")
end
local val = expr(ast, ls)
- kvs[(#kvs + 1)] = {val, key}
+ do end (kvs)[(#kvs + 1)] = {val, key}
if (not lex_opt(ls, ",") and not lex_opt(ls, ";")) then
break
end
@@ 1483,8 1589,8 @@ package.preload["lang.parser"] = package.preload["lang.parser"] or function(...)
lex_match(ls, "}", "{", line)
return ast:expr_table(kvs, line)
end
- expr_table = _0_
- local function _1_(ast, ls)
+ expr_table = _64_
+ local function _67_(ast, ls)
local tk, val = ls.token, ls.tokenval
local e = nil
if (tk == "TK_number") then
@@ 1517,8 1623,8 @@ package.preload["lang.parser"] = package.preload["lang.parser"] or function(...)
ls:next()
return e
end
- expr_simple = _1_
- local function _2_(ast, ls)
+ expr_simple = _67_
+ local function _70_(ast, ls)
local exps = {}
exps[1] = expr(ast, ls)
while lex_opt(ls, ",") do
@@ 1530,8 1636,8 @@ package.preload["lang.parser"] = package.preload["lang.parser"] or function(...)
end
return exps
end
- expr_list = _2_
- local function _3_(ast, ls)
+ expr_list = _70_
+ local function _72_(ast, ls)
local tk = ls.token
if (((tk == "TK_not") or (tk == "-")) or (tk == "#")) then
local line = ls.linenumber
@@ 1542,8 1648,8 @@ package.preload["lang.parser"] = package.preload["lang.parser"] or function(...)
return expr_simple(ast, ls)
end
end
- expr_unop = _3_
- local function _4_(ast, ls, limit)
+ expr_unop = _72_
+ local function _74_(ast, ls, limit)
local v = expr_unop(ast, ls)
local op = ls.token2str(ls.token)
while (operator.is_binop(op) and (operator.left_priority(op) > limit)) do
@@ 1555,12 1661,12 @@ package.preload["lang.parser"] = package.preload["lang.parser"] or function(...)
end
return v, op
end
- expr_binop = _4_
- local function _5_(ast, ls)
+ expr_binop = _74_
+ local function _75_(ast, ls)
return expr_binop(ast, ls, 0)
end
- expr = _5_
- local function _6_(ast, ls)
+ expr = _75_
+ local function _76_(ast, ls)
local v, vk = nil
if (ls.token == "(") then
local line = ls.linenumber
@@ 1593,7 1699,7 @@ package.preload["lang.parser"] = package.preload["lang.parser"] or function(...)
end
return v, vk
end
- expr_primary = _6_
+ expr_primary = _76_
local function parse_return(ast, ls, line)
ls:next()
ls.fs.has_return = true
@@ 1657,7 1763,7 @@ package.preload["lang.parser"] = package.preload["lang.parser"] or function(...)
ast:fscope_end()
return ast:repeat_stmt(cond, body, line, lastline)
end
- local function _7_(ast, ls)
+ local function _82_(ast, ls)
local line = ls.linenumber
local args = nil
if (ls.token == "(") then
@@ 1683,11 1789,11 @@ package.preload["lang.parser"] = package.preload["lang.parser"] or function(...)
end
return args
end
- parse_args = _7_
+ parse_args = _82_
local function parse_assignment(ast, ls, vlist, ___var___, vk)
local line = ls.linenumber
checkcond(ls, ((vk == "var") or (vk == "indexed")), "syntax error")
- vlist[(#vlist + 1)] = ___var___
+ do end (vlist)[(#vlist + 1)] = ___var___
if lex_opt(ls, ",") then
local n_var, n_vk = expr_primary(ast, ls)
return parse_assignment(ast, ls, vlist, n_var, n_vk)
@@ 1757,7 1863,7 @@ package.preload["lang.parser"] = package.preload["lang.parser"] or function(...)
end
local function parse_then(ast, ls, tests, line)
ls:next()
- tests[(#tests + 1)] = expr(ast, ls)
+ do end (tests)[(#tests + 1)] = expr(ast, ls)
lex_check(ls, "TK_then")
return parse_block(ast, ls, line)
end
@@ 1855,7 1961,7 @@ package.preload["lang.parser"] = package.preload["lang.parser"] or function(...)
local function tk_args()
if ((ls.token == "TK_name") or (not LJ_52 and (ls.token == "TK_goto"))) then
local name = lex_str(ls)
- args[(#args + 1)] = name
+ do end (args)[(#args + 1)] = name
if lex_opt(ls, ",") then
return tk_args()
end
@@ 1884,7 1990,7 @@ package.preload["lang.parser"] = package.preload["lang.parser"] or function(...)
local body = {}
while (not islast and not End_of_block[ls.token]) do
stmt, islast = parse_stmt(ast, ls)
- body[(#body + 1)] = stmt
+ do end (body)[(#body + 1)] = stmt
lex_opt(ls, ";")
end
return body, firstline, ls.linenumber
@@ 1893,7 1999,7 @@ package.preload["lang.parser"] = package.preload["lang.parser"] or function(...)
local body, firstline, lastline = parse_block_stmts(ast, ls)
return ast:chunk(body, ls.chunkname, 0, lastline)
end
- local function _8_(ast, ls, line, needself)
+ local function _102_(ast, ls, line, needself)
local pfs = ls.fs
ls.fs = new_proto(ls, false)
ast:fscope_begin()
@@ 1912,15 2018,15 @@ package.preload["lang.parser"] = package.preload["lang.parser"] or function(...)
ls.fs = pfs
return params, body, proto
end
- parse_body = _8_
- local function _9_(ast, ls, firstline)
+ parse_body = _102_
+ local function _104_(ast, ls, firstline)
ast:fscope_begin()
local body = parse_block_stmts(ast, ls)
body.firstline, body.lastline = firstline, ls.linenumber
ast:fscope_end()
return body
end
- parse_block = _9_
+ parse_block = _104_
local function parse(ast, ls)
ls:next()
ls.fs = new_proto(ls, true)
@@ 2456,7 2562,7 @@ package.preload["lang.lexer"] = package.preload["lang.lexer"] or function(...)
end
return lex_setup
end
-local fennel = nil
+local fennel
package.preload["fennel"] = package.preload["fennel"] or function(...)
package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
local utils = require("fennel.utils")
@@ 2510,6 2616,77 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
end
return table.concat(spliced_source, "\n")
end
+ local function completer(env, scope, text)
+ local matches = {}
+ local input_fragment = text:gsub(".*[%s)(]+", "")
+ local stop_looking_3f = false
+ local function add_partials(input, tbl, prefix, method_3f)
+ for k in utils.allpairs(tbl) do
+ local k0 = nil
+ if ((tbl == env) or (tbl == env.___replLocals___)) then
+ k0 = scope.unmanglings[k]
+ else
+ k0 = k
+ end
+ if ((#matches < 2000) and (type(k0) == "string") and (input == k0:sub(0, #input)) and (not method_3f or ("function" == type(tbl[k0])))) then
+ local function _1_()
+ if method_3f then
+ return (prefix .. ":" .. k0)
+ else
+ return (prefix .. k0)
+ end
+ end
+ table.insert(matches, _1_())
+ end
+ end
+ return nil
+ end
+ local function descend(input, tbl, prefix, add_matches, method_3f)
+ local splitter = nil
+ if method_3f then
+ splitter = "^([^:]+):(.*)"
+ else
+ splitter = "^([^.]+)%.(.*)"
+ end
+ local head, tail = input:match(splitter)
+ local raw_head = nil
+ if ((tbl == env) or (tbl == env.___replLocals___)) then
+ raw_head = scope.manglings[head]
+ else
+ raw_head = head
+ end
+ if (type(tbl[raw_head]) == "table") then
+ stop_looking_3f = true
+ if method_3f then
+ return add_partials(tail, tbl[raw_head], (prefix .. head), true)
+ else
+ return add_matches(tail, tbl[raw_head], (prefix .. head))
+ end
+ end
+ end
+ local function add_matches(input, tbl, prefix)
+ local prefix0 = nil
+ if prefix then
+ prefix0 = (prefix .. ".")
+ else
+ prefix0 = ""
+ end
+ if (not input:find("%.") and input:find(":")) then
+ return descend(input, tbl, prefix0, add_matches, true)
+ elseif not input:find("%.") then
+ return add_partials(input, tbl, prefix0)
+ else
+ return descend(input, tbl, prefix0, add_matches, false)
+ end
+ end
+ for _, source in ipairs({scope.specials, scope.macros, (env.___replLocals___ or {}), env, env._G}) do
+ add_matches(input_fragment, source)
+ if stop_looking_3f then
+ break
+ end
+ end
+ return matches
+ end
local commands = {}
local function command_3f(input)
return input:match("^%s*,")
@@ 2582,6 2759,138 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
return on_values({"ok"})
end
do end (compiler.metadata):set(commands.reset, "fnl/docstring", "Erase all repl-local scope.")
+ commands.complete = function(env, read, on_values, on_error, scope)
+ local _0_0, _1_0, _2_0 = pcall(read)
+ if ((_0_0 == true) and (_1_0 == true) and (nil ~= _2_0)) then
+ local input = _2_0
+ return on_values(completer(env, scope, tostring(input)))
+ elseif (true and true and true) then
+ local _ = _0_0
+ local _0 = _1_0
+ local _3fmsg = _2_0
+ return on_error("Parse", (_3fmsg or "Couldn't parse completion input."))
+ end
+ end
+ do end (compiler.metadata):set(commands.complete, "fnl/docstring", "Print all possible completions for a given input.")
+ local function apropos_2a(pattern, module, prefix, seen, names)
+ for name, module0 in pairs(module) do
+ if (("string" == type(name)) and (package ~= module0)) then
+ local _0_0 = type(module0)
+ if (_0_0 == "function") then
+ if ((prefix .. name)):match(pattern) then
+ table.insert(names, (prefix .. name))
+ end
+ elseif (_0_0 == "table") then
+ if not seen[module0] then
+ local _2_
+ do
+ local _1_0 = seen
+ _1_0[module0] = true
+ _2_ = _1_0
+ end
+ apropos_2a(pattern, module0, (prefix .. name:gsub("%.", "/") .. "."), _2_, names)
+ end
+ end
+ end
+ end
+ return names
+ end
+ local function apropos(pattern)
+ local names = apropos_2a(pattern, package.loaded, "", {}, {})
+ local tbl_0_ = {}
+ for _, name in ipairs(names) do
+ tbl_0_[(#tbl_0_ + 1)] = name:gsub("^_G%.", "")
+ end
+ return tbl_0_
+ end
+ commands.apropos = function(env, read, on_values, on_error, scope)
+ local _0_0, _1_0, _2_0 = pcall(read)
+ if ((_0_0 == true) and (_1_0 == true) and (nil ~= _2_0)) then
+ local input = _2_0
+ return on_values(apropos(tostring(input)))
+ elseif (true and true and true) then
+ local _ = _0_0
+ local _0 = _1_0
+ local _3fmsg = _2_0
+ return on_error("Parse", (_3fmsg or "Couldn't parse apropos input."))
+ end
+ end
+ do end (compiler.metadata):set(commands.apropos, "fnl/docstring", "Print all functions matching a pattern in all loaded modules.")
+ local function apropos_follow_path(path)
+ local paths = nil
+ do
+ local tbl_0_ = {}
+ for p in path:gmatch("[^%.]+") do
+ tbl_0_[(#tbl_0_ + 1)] = p
+ end
+ paths = tbl_0_
+ end
+ local tgt = package.loaded
+ for _, path0 in ipairs(paths) do
+ local _1_
+ do
+ local _0_0 = path0:gsub("%/", ".")
+ _1_ = _0_0
+ end
+ tgt = tgt[_1_]
+ if (nil == tgt) then
+ break
+ end
+ end
+ return tgt
+ end
+ local function apropos_doc(pattern)
+ local names = {}
+ for _, path in ipairs(apropos(".*")) do
+ local tgt = apropos_follow_path(path)
+ if ("function" == type(tgt)) then
+ local _0_0 = (compiler.metadata):get(tgt, "fnl/docstring")
+ if (nil ~= _0_0) then
+ local docstr = _0_0
+ if docstr:match(pattern) then
+ table.insert(names, path)
+ end
+ end
+ end
+ end
+ return names
+ end
+ commands["apropos-doc"] = function(env, read, on_values, on_error, scope)
+ local _0_0, _1_0, _2_0 = pcall(read)
+ if ((_0_0 == true) and (_1_0 == true) and (nil ~= _2_0)) then
+ local input = _2_0
+ return on_values(apropos_doc(tostring(input)))
+ elseif (true and true and true) then
+ local _ = _0_0
+ local _0 = _1_0
+ local _3fmsg = _2_0
+ return on_error("Parse", (_3fmsg or "Couldn't parse apropos-doc input."))
+ end
+ end
+ do end (compiler.metadata):set(commands["apropos-doc"], "fnl/docstring", "Print all functions that match the pattern in their docs")
+ local function apropos_show_docs(pattern)
+ for _, path in ipairs(apropos(pattern)) do
+ local tgt = apropos_follow_path(path)
+ if (("function" == type(tgt)) and (compiler.metadata):get(tgt, "fnl/docstring")) then
+ print(specials.doc(tgt, path))
+ print()
+ end
+ end
+ return nil
+ end
+ commands["apropos-show-docs"] = function(env, read, _, on_error, scope)
+ local _0_0, _1_0, _2_0 = pcall(read)
+ if ((_0_0 == true) and (_1_0 == true) and (nil ~= _2_0)) then
+ local input = _2_0
+ return apropos_show_docs(tostring(input))
+ elseif (true and true and true) then
+ local _0 = _0_0
+ local _1 = _1_0
+ local _3fmsg = _2_0
+ return on_error("Parse", (_3fmsg or "Couldn't parse apropos-show-docs input."))
+ end
+ end
+ do end (compiler.metadata):set(commands["apropos-show-docs"], "fnl/docstring", "Print all documentations matching a pattern in function name")
local function load_plugin_commands()
if (utils.root and utils.root.options and utils.root.options.plugins) then
for _, plugin in ipairs(utils.root.options.plugins) do
@@ 2596,14 2905,14 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
return nil
end
end
- local function run_command(input, read, loop, env, on_values, on_error)
+ local function run_command(input, read, loop, env, on_values, on_error, scope)
load_plugin_commands()
local command_name = input:match(",([^%s/]+)")
do
local _0_0 = commands[command_name]
if (nil ~= _0_0) then
local command = _0_0
- command(env, read, on_values, on_error)
+ command(env, read, on_values, on_error, scope)
else
local _ = _0_0
if ("exit" ~= command_name) then
@@ 2615,52 2924,6 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
return loop()
end
end
- local function completer(env, scope, text)
- local matches = {}
- local input_fragment = text:gsub(".*[%s)(]+", "")
- local function add_partials(input, tbl, prefix)
- for k in utils.allpairs(tbl) do
- local k0 = nil
- if ((tbl == env) or (tbl == env.___replLocals___)) then
- k0 = scope.unmanglings[k]
- else
- k0 = k
- end
- if ((#matches < 2000) and (type(k0) == "string") and (input == k0:sub(0, #input))) then
- table.insert(matches, (prefix .. k0))
- end
- end
- return nil
- end
- local function add_matches(input, tbl, prefix)
- local prefix0 = nil
- if prefix then
- prefix0 = (prefix .. ".")
- else
- prefix0 = ""
- end
- if not input:find("%.") then
- return add_partials(input, tbl, prefix0)
- else
- local head, tail = input:match("^([^.]+)%.(.*)")
- local raw_head = nil
- if ((tbl == env) or (tbl == env.___replLocals___)) then
- raw_head = scope.manglings[head]
- else
- raw_head = head
- end
- if (type(tbl[raw_head]) == "table") then
- return add_matches(tail, tbl[raw_head], (prefix0 .. head))
- end
- end
- end
- add_matches(input_fragment, (scope.specials or {}))
- add_matches(input_fragment, (scope.macros or {}))
- add_matches(input_fragment, (env.___replLocals___ or {}))
- add_matches(input_fragment, env)
- add_matches(input_fragment, (env._ENV or env._G or {}))
- return matches
- end
local function repl(options)
local old_root_options = utils.root.options
local env = nil
@@ 2722,11 2985,11 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
reset()
return loop()
elseif command_3f(src_string) then
- return run_command(src_string, read, loop, env, on_values, on_error)
+ return run_command(src_string, read, loop, env, on_values, on_error, scope)
else
if parse_ok_3f then
do
- local _4_0, _5_0 = pcall(compiler.compile, x, {["assert-compile"] = opts["assert-compile"], ["parse-error"] = opts["parse-error"], correlate = opts.correlate, moduleName = opts.moduleName, scope = scope, source = src_string, useMetadata = opts.useMetadata})
+ local _4_0, _5_0 = pcall(compiler.compile, x, {["assert-compile"] = opts["assert-compile"], ["parse-error"] = opts["parse-error"], correlate = opts.correlate, moduleName = opts.moduleName, scope = scope, source = src_string, useBitLib = opts.useBitLib, useMetadata = opts.useMetadata})
if ((_4_0 == false) and (nil ~= _5_0)) then
local msg = _5_0
clear_stream()
@@ 2791,30 3054,73 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
end
end
end
- local function table_kv_pairs(t)
+ local function max_index_gap(kv)
+ local gap = 0
+ if (#kv > 0) then
+ local _2_ = kv
+ local _3_ = _2_[1]
+ local i = _3_[1]
+ local rest = {(table.unpack or unpack)(_2_, 2)}
+ for _, _4_0 in ipairs(rest) do
+ local _5_ = _4_0
+ local k = _5_[1]
+ if ((k - i) > gap) then
+ gap = (k - i)
+ end
+ i = k
+ end
+ end
+ return gap
+ end
+ local function fill_gaps(kv)
+ do
+ local missing_indexes = {}
+ local i = 0
+ for _, _2_0 in ipairs(kv) do
+ local _3_ = _2_0
+ local j = _3_[1]
+ i = (i + 1)
+ while (i < j) do
+ table.insert(missing_indexes, i)
+ i = (i + 1)
+ end
+ end
+ for _, k in ipairs(missing_indexes) do
+ table.insert(kv, k, {k})
+ end
+ end
+ return kv
+ end
+ local function table_kv_pairs(t, options)
local assoc_3f = false
- local i = 1
local kv = {}
local insert = table.insert
for k, v in pairs(t) do
- if ((type(k) ~= "number") or (k ~= i)) then
+ if (type(k) ~= "number") then
assoc_3f = true
end
- i = (i + 1)
insert(kv, {k, v})
end
table.sort(kv, sort_keys)
+ if not assoc_3f then
+ local gap = max_index_gap(kv)
+ if (max_index_gap(kv) > options["max-sparse-gap"]) then
+ assoc_3f = true
+ else
+ fill_gaps(kv)
+ end
+ end
if (#kv == 0) then
return kv, "empty"
else
- local function _2_()
+ local function _3_()
if assoc_3f then
return "table"
else
return "seq"
end
end
- return kv, _2_()
+ return kv, _3_()
end
end
local function count_table_appearances(t, appearances)
@@ 2918,7 3224,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
else
prefix = ""
end
- local elements = nil
+ local items = nil
do
local tbl_0_ = {}
for _, _6_0 in pairs(kv) do
@@ 2934,9 3240,9 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
end
tbl_0_[(#tbl_0_ + 1)] = _8_
end
- elements = tbl_0_
+ items = tbl_0_
end
- return concat_table_lines(elements, options, multiline_3f, indent0, "table", prefix)
+ return concat_table_lines(items, options, multiline_3f, indent0, "table", prefix)
end
end
local function pp_sequence(t, kv, options, indent)
@@ 2956,7 3262,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
else
prefix = ""
end
- local elements = nil
+ local items = nil
do
local tbl_0_ = {}
for _, _3_0 in pairs(kv) do
@@ 2971,9 3277,9 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
end
tbl_0_[(#tbl_0_ + 1)] = _5_
end
- elements = tbl_0_
+ items = tbl_0_
end
- return concat_table_lines(elements, options, multiline_3f, indent0, "seq", prefix)
+ return concat_table_lines(items, options, multiline_3f, indent0, "seq", prefix)
end
end
local function concat_lines(lines, options, indent, force_multi_line_3f)
@@ 3024,7 3330,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
return concat_lines(lines, options, indent, force_multi_line_3f)
else
local _0 = _3_0
- return error("Error: __fennelview metamethod must return a table of lines")
+ return error("__fennelview metamethod must return a table of lines")
end
end
end
@@ 3053,7 3359,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
x0 = pp_metamethod(x, metamethod, options, indent)
else
local _ = _2_0
- local _4_0, _5_0 = table_kv_pairs(x)
+ local _4_0, _5_0 = table_kv_pairs(x, options)
if (true and (_5_0 == "empty")) then
local _0 = _4_0
if options["empty-as-sequence?"] then
@@ 3097,7 3403,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
return ("\"" .. str:gsub("[%c\\\"]", escs) .. "\"")
end
local function make_options(t, options)
- local defaults = {["detect-cycles?"] = true, ["empty-as-sequence?"] = false, ["escape-newlines?"] = false, ["line-length"] = 80, ["metamethod?"] = true, ["one-line?"] = false, ["prefer-colon?"] = false, ["utf8?"] = true, depth = 128}
+ local defaults = {["detect-cycles?"] = true, ["empty-as-sequence?"] = false, ["escape-newlines?"] = false, ["line-length"] = 80, ["max-sparse-gap"] = 10, ["metamethod?"] = true, ["one-line?"] = false, ["prefer-colon?"] = false, ["utf8?"] = true, depth = 128}
local overrides = {appearances = count_table_appearances(t, {}), level = 0, seen = {len = 0}}
for k, v in pairs((options or {})) do
defaults[k] = v
@@ 3189,7 3495,28 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
return setmetatable({}, {__index = _0_, __newindex = _1_, __pairs = _2_})
end
local function current_global_names(env)
- return utils.kvmap((env or _G), compiler["global-unmangling"])
+ local mt = nil
+ do
+ local _0_0 = getmetatable(env)
+ if ((type(_0_0) == "table") and (nil ~= _0_0.__pairs)) then
+ local __pairs = _0_0.__pairs
+ local tbl_0_ = {}
+ for k, v in __pairs(env) do
+ local _1_0, _2_0 = k, v
+ if ((nil ~= _1_0) and (nil ~= _2_0)) then
+ local k_0_ = _1_0
+ local v_0_ = _2_0
+ tbl_0_[k_0_] = v_0_
+ end
+ end
+ mt = tbl_0_
+ elseif (_0_0 == nil) then
+ mt = (env or _G)
+ else
+ mt = nil
+ end
+ end
+ return (mt and utils.kvmap(mt, compiler["global-unmangling"]))
end
local function load_code(code, environment, filename)
local environment0 = (environment or rawget(_G, "_ENV") or _G)
@@ 3221,8 3548,8 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
end
end
end
- local function doc_special(name, arglist, docstring)
- compiler.metadata[SPECIALS[name]] = {["fnl/arglist"] = arglist, ["fnl/docstring"] = docstring}
+ local function doc_special(name, arglist, docstring, body_form_3f)
+ compiler.metadata[SPECIALS[name]] = {["fnl/arglist"] = arglist, ["fnl/body-form?"] = body_form_3f, ["fnl/docstring"] = docstring}
return nil
end
local function compile_do(ast, scope, parent, start)
@@ 3284,7 3611,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
return compile_body(nil, true, utils.expr((fname .. "(" .. fargs .. ")"), "statement"))
end
end
- doc_special("do", {"..."}, "Evaluate multiple forms; return last value.")
+ doc_special("do", {"..."}, "Evaluate multiple forms; return last value.", true)
SPECIALS.values = function(ast, scope, parent)
local len = #ast
local exprs = {}
@@ 3333,8 3660,8 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
local function set_fn_metadata(arg_list, docstring, parent, fn_name)
if utils.root.options.useMetadata then
local args = nil
- local function _0_(v)
- return ("\"%s\""):format(deep_tostring(v))
+ local function _0_(_241)
+ return ("\"%s\""):format(deep_tostring(_241))
end
args = utils.map(arg_list, _0_)
local meta_fields = {"\"fnl/arglist\"", ("{" .. table.concat(args, ", ") .. "}")}
@@ 3356,9 3683,30 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
end
return _0_, not multi, 3
else
- return compiler.gensym(scope), true, 2
+ return nil, true, 2
end
end
+ local function compile_named_fn(ast, f_scope, f_chunk, parent, index, fn_name, local_3f, arg_name_list, arg_list, docstring)
+ for i = (index + 1), #ast do
+ compiler.compile1(ast[i], f_scope, f_chunk, {nval = (((i ~= #ast) and 0) or nil), tail = (i == #ast)})
+ end
+ local _0_
+ if local_3f then
+ _0_ = "local function %s(%s)"
+ else
+ _0_ = "%s = function(%s)"
+ end
+ compiler.emit(parent, string.format(_0_, 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)
+ utils.hook("fn", ast, f_scope)
+ return utils.expr(fn_name, "sym")
+ end
+ local function compile_anonymous_fn(ast, f_scope, f_chunk, parent, index, arg_name_list, arg_list, docstring, scope)
+ local fn_name = compiler.gensym(scope)
+ return compile_named_fn(ast, f_scope, f_chunk, parent, index, fn_name, true, arg_name_list, arg_list, docstring)
+ end
SPECIALS.fn = function(ast, scope, parent)
local f_scope = nil
do
@@ 3369,7 3717,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
local f_chunk = {}
local fn_sym = utils["sym?"](ast[2])
local multi = (fn_sym and utils["multi-sym?"](fn_sym[1]))
- local fn_name, local_fn_3f, index = get_fn_name(ast, scope, fn_sym, multi)
+ local fn_name, local_3f, index = get_fn_name(ast, scope, fn_sym, multi)
local arg_list = compiler.assert(utils["table?"](ast[index]), "expected parameters table", ast)
compiler.assert((not multi or not multi["multi-sym-method-call"]), ("unexpected multi symbol " .. tostring(fn_name)), fn_sym)
local function get_arg_name(arg)
@@ 3388,32 3736,20 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
return compiler.assert(false, ("expected symbol for function parameter: %s"):format(tostring(arg)), ast[2])
end
end
- do
- local arg_name_list = utils.map(arg_list, get_arg_name)
- local index0, docstring = nil, nil
- if ((type(ast[(index + 1)]) == "string") and ((index + 1) < #ast)) then
- index0, docstring = (index + 1), ast[(index + 1)]
- else
- index0, docstring = index, nil
- end
- 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
- _2_ = "local function %s(%s)"
- else
- _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)
+ local arg_name_list = utils.map(arg_list, get_arg_name)
+ local index0, docstring = nil, nil
+ if ((type(ast[(index + 1)]) == "string") and ((index + 1) < #ast)) then
+ index0, docstring = (index + 1), ast[(index + 1)]
+ else
+ index0, docstring = index, nil
+ end
+ if fn_name then
+ return compile_named_fn(ast, f_scope, f_chunk, parent, index0, fn_name, local_3f, arg_name_list, arg_list, docstring)
+ else
+ return compile_anonymous_fn(ast, f_scope, f_chunk, parent, index0, arg_name_list, arg_list, docstring, scope)
end
- utils.hook("fn", ast, f_scope)
- return utils.expr(fn_name, "sym")
end
- doc_special("fn", {"name?", "args", "docstring?", "..."}, "Function syntax. May optionally include a name and docstring.\nIf a name is provided, the function will be bound in the current scope.\nWhen called with the wrong number of args, excess args will be discarded\nand lacking args will be nil, use lambda for arity-checked functions.")
+ doc_special("fn", {"name?", "args", "docstring?", "..."}, "Function syntax. May optionally include a name and docstring.\nIf a name is provided, the function will be bound in the current scope.\nWhen called with the wrong number of args, excess args will be discarded\nand lacking args will be nil, use lambda for arity-checked functions.", true)
SPECIALS.lua = function(ast, _, parent)
compiler.assert(((#ast == 2) or (#ast == 3)), "expected 1 or 2 arguments", ast)
if (ast[2] ~= nil) then
@@ 3431,8 3767,9 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
if special_or_macro then
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]))
+ local _0_ = compiler.compile1(ast[2], scope, parent, {nval = 1})
+ local value = _0_[1]
+ return ("print(require('%s').doc(%s, '%s'))"):format((utils.root.options.moduleName or "fennel"), tostring(value), tostring(ast[2]))
end
end
doc_special("doc", {"x"}, "Print the docstring and arglist for a function, macro, or special form.")
@@ 3511,7 3848,24 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
end
return SPECIALS["do"](ast, scope, parent, opts, 3, sub_chunk, sub_scope, pre_syms)
end
- doc_special("let", {"[name1 val1 ... nameN valN]", "..."}, "Introduces a new scope in which a given set of local bindings are used.")
+ doc_special("let", {"[name1 val1 ... nameN valN]", "..."}, "Introduces a new scope in which a given set of local bindings are used.", true)
+ local function get_prev_line(parent)
+ if ("table" == type(parent)) then
+ return get_prev_line((parent.leaf or parent[#parent]))
+ else
+ return (parent or "")
+ end
+ end
+ local function disambiguate_3f(rootstr, parent)
+ local function _1_()
+ local _0_0 = get_prev_line(parent)
+ if (nil ~= _0_0) then
+ local prev_line = _0_0
+ return prev_line:match("%)$")
+ end
+ end
+ return (rootstr:match("^{") or _1_())
+ end
SPECIALS.tset = function(ast, scope, parent)
compiler.assert((#ast > 3), "expected table, key, and value arguments", ast)
local root = compiler.compile1(ast[2], scope, parent, {nval = 1})[1]
@@ 3524,12 3878,12 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
local value = compiler.compile1(ast[#ast], scope, parent, {nval = 1})[1]
local rootstr = tostring(root)
local fmtstr = nil
- if rootstr:match("^{") then
+ if disambiguate_3f(rootstr, parent) then
fmtstr = "do end (%s)[%s] = %s"
else
fmtstr = "%s[%s] = %s"
end
- return compiler.emit(parent, fmtstr:format(tostring(root), table.concat(keys, "]["), tostring(value)), ast)
+ return compiler.emit(parent, fmtstr:format(rootstr, table.concat(keys, "]["), tostring(value)), ast)
end
doc_special("tset", {"tbl", "key1", "...", "keyN", "val"}, "Set the value of a table field. Can take additional keys to set\nnested values, but all parents must contain an existing table.")
local function calculate_target(scope, opts)
@@ 3584,7 3938,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
end
local cond = tostring(branch.cond)
local cond_line = nil
- if ((cond == "true") and branch.nested and (i == #branches)) then
+ if ((cond == "true") and branch.nested and (i == #branches) and not has_else_3f) then
cond_line = "else"
else
cond_line = fstr:format(cond)
@@ 3636,9 3990,24 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
end
SPECIALS["if"] = if_2a
doc_special("if", {"cond1", "body1", "...", "condN", "bodyN"}, "Conditional form.\nTakes any number of condition/body pairs and evaluates the first body where\nthe condition evaluates to truthy. Similar to cond in other lisps.")
+ local function remove_until_condition(bindings)
+ if ("until" == bindings[(#bindings - 1)]) then
+ table.remove(bindings, (#bindings - 1))
+ return table.remove(bindings)
+ end
+ end
+ local function compile_until(condition, scope, chunk)
+ if condition then
+ local _0_ = compiler.compile1(condition, scope, chunk, {nval = 1})
+ local condition_lua = _0_[1]
+ return compiler.emit(chunk, ("if %s then break end"):format(tostring(condition_lua)), condition)
+ end
+ end
SPECIALS.each = function(ast, scope, parent)
compiler.assert((#ast >= 3), "expected body expression", ast[1])
local binding = compiler.assert(utils["table?"](ast[2]), "expected binding table", ast)
+ local _ = compiler.assert((2 <= #binding), "expected binding and iterator", binding)
+ local until_condition = remove_until_condition(binding)
local iter = table.remove(binding, #binding)
local destructures = {}
local new_manglings = {}
@@ 3661,11 4030,12 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
compiler.destructure(args, raw, ast, sub_scope, chunk, {declaration = true, nomulti = true, symtype = "each"})
end
compiler["apply-manglings"](sub_scope, new_manglings, ast)
+ compile_until(until_condition, sub_scope, chunk)
compile_do(ast, sub_scope, chunk, 3)
compiler.emit(parent, chunk, ast)
return compiler.emit(parent, "end", ast)
end
- doc_special("each", {"[key value (iterator)]", "..."}, "Runs the body once for each set of values provided by the given iterator.\nMost commonly used with ipairs for sequential tables or pairs for undefined\norder, but can be used with any iterator.")
+ doc_special("each", {"[key value (iterator)]", "..."}, "Runs the body once for each set of values provided by the given iterator.\nMost commonly used with ipairs for sequential tables or pairs for undefined\norder, but can be used with any iterator.", true)
local function while_2a(ast, scope, parent)
local len1 = #parent
local condition = compiler.compile1(ast[2], scope, parent, {nval = 1})[1]
@@ 3686,9 4056,10 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
return compiler.emit(parent, "end", ast)
end
SPECIALS["while"] = while_2a
- doc_special("while", {"condition", "..."}, "The classic while loop. Evaluates body until a condition is non-truthy.")
+ doc_special("while", {"condition", "..."}, "The classic while loop. Evaluates body until a condition is non-truthy.", true)
local function for_2a(ast, scope, parent)
local ranges = compiler.assert(utils["table?"](ast[2]), "expected binding table", ast)
+ local until_condition = remove_until_condition(ast[2])
local binding_sym = table.remove(ast[2], 1)
local sub_scope = compiler["make-scope"](scope)
local range_args = {}
@@ 3699,12 4070,13 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
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)
+ compile_until(until_condition, sub_scope, chunk)
compile_do(ast, sub_scope, chunk, 3)
compiler.emit(parent, chunk, ast)
return compiler.emit(parent, "end", ast)
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).")
+ doc_special("for", {"[index start stop step?]", "..."}, "Numeric loop construct.\nEvaluates body once for each value between start and stop (inclusive).", true)
local function native_method_call(ast, _scope, _parent, target, args)
local _0_ = ast
local _ = _0_[1]
@@ 3766,7 4138,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
end
return compiler.emit(parent, ("-- " .. table.concat(els, " ")), ast)
end
- doc_special("comment", {"..."}, "Comment which will be emitted in Lua output.")
+ doc_special("comment", {"..."}, "Comment which will be emitted in Lua output.", true)
local function hashfn_max_used(f_scope, i, max)
local max0 = nil
if f_scope.symmeta[("$" .. i)].used then
@@ 3824,40 4196,35 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
return utils.expr(name, "sym")
end
doc_special("hashfn", {"..."}, "Function literal shorthand; args are either $... OR $1, $2, etc.")
- local function define_arithmetic_special(name, zero_arity, unary_prefix, lua_name)
- do
- local padded_op = (" " .. (lua_name or name) .. " ")
- local function _0_(ast, scope, parent)
- local len = #ast
- if (len == 1) then
- compiler.assert((zero_arity ~= nil), "Expected more than 0 arguments", ast)
- return utils.expr(zero_arity, "literal")
+ local function arithmetic_special(name, zero_arity, unary_prefix, nval, ast, scope, parent)
+ local _0_0 = #ast
+ if (_0_0 == 1) then
+ compiler.assert(zero_arity, "Expected more than 0 arguments", ast)
+ return utils.expr(zero_arity, "literal")
+ elseif (nil ~= _0_0) then
+ local len = _0_0
+ local operands = {}
+ local padded_op = (" " .. name .. " ")
+ for i = 2, len do
+ local subexprs = compiler.compile1(ast[i], scope, parent, {nval = nval})
+ utils.map(subexprs, tostring, operands)
+ end
+ if (#operands == 1) then
+ if unary_prefix then
+ return ("(" .. unary_prefix .. padded_op .. operands[1] .. ")")
else
- local operands = {}
- for i = 2, len do
- local subexprs = nil
- local _1_
- if (i ~= len) then
- _1_ = 1
- else
- _1_ = nil
- end
- subexprs = compiler.compile1(ast[i], scope, parent, {nval = _1_})
- utils.map(subexprs, tostring, operands)
- end
- if (#operands == 1) then
- if unary_prefix then
- return ("(" .. unary_prefix .. padded_op .. operands[1] .. ")")
- else
- return operands[1]
- end
- else
- return ("(" .. table.concat(operands, padded_op) .. ")")
- end
+ return operands[1]
end
+ else
+ return ("(" .. table.concat(operands, padded_op) .. ")")
end
- SPECIALS[name] = _0_
end
+ end
+ local function define_arithmetic_special(name, zero_arity, unary_prefix, lua_name)
+ local function _0_(...)
+ return arithmetic_special((lua_name or name), zero_arity, unary_prefix, 1, ...)
+ end
+ SPECIALS[name] = _0_
return doc_special(name, {"a", "b", "..."}, "Arithmetic operator; works the same as Lua but accepts more arguments.")
end
define_arithmetic_special("+", "0")
@@ 3868,20 4235,65 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
define_arithmetic_special("%")
define_arithmetic_special("/", nil, "1")
define_arithmetic_special("//", nil, "1")
- define_arithmetic_special("lshift", nil, "1", "<<")
- define_arithmetic_special("rshift", nil, "1", ">>")
- define_arithmetic_special("band", "0", "0", "&")
- define_arithmetic_special("bor", "0", "0", "|")
- define_arithmetic_special("bxor", "0", "0", "~")
- doc_special("lshift", {"x", "n"}, "Bitwise logical left shift of x by n bits; only works in Lua 5.3+.")
- doc_special("rshift", {"x", "n"}, "Bitwise logical right shift of x by n bits; only works in Lua 5.3+.")
- doc_special("band", {"x1", "x2"}, "Bitwise AND of arguments; only works in Lua 5.3+.")
- doc_special("bor", {"x1", "x2"}, "Bitwise OR of arguments; only works in Lua 5.3+.")
- doc_special("bxor", {"x1", "x2"}, "Bitwise XOR of arguments; only works in Lua 5.3+.")
- define_arithmetic_special("or", "false")
- define_arithmetic_special("and", "true")
+ SPECIALS["or"] = function(ast, scope, parent)
+ return arithmetic_special("or", "false", nil, nil, ast, scope, parent)
+ end
+ SPECIALS["and"] = function(ast, scope, parent)
+ return arithmetic_special("and", "true", nil, nil, ast, scope, parent)
+ end
doc_special("and", {"a", "b", "..."}, "Boolean operator; works the same as Lua but accepts more arguments.")
doc_special("or", {"a", "b", "..."}, "Boolean operator; works the same as Lua but accepts more arguments.")
+ local function bitop_special(native_name, lib_name, zero_arity, unary_prefix, ast, scope, parent)
+ if (#ast == 1) then
+ return compiler.assert(zero_arity, "Expected more than 0 arguments.", ast)
+ else
+ local len = #ast
+ local operands = {}
+ local padded_native_name = (" " .. native_name .. " ")
+ local prefixed_lib_name = ("bit." .. lib_name)
+ for i = 2, len do
+ local subexprs = nil
+ local _0_
+ if (i ~= len) then
+ _0_ = 1
+ else
+ _0_ = nil
+ end
+ subexprs = compiler.compile1(ast[i], scope, parent, {nval = _0_})
+ utils.map(subexprs, tostring, operands)
+ end
+ if (#operands == 1) then
+ if utils.root.options.useBitLib then
+ return (prefixed_lib_name .. "(" .. unary_prefix .. ", " .. operands[1] .. ")")
+ else
+ return ("(" .. unary_prefix .. padded_native_name .. operands[1] .. ")")
+ end
+ else
+ if utils.root.options.useBitLib then
+ return (prefixed_lib_name .. "(" .. table.concat(operands, ", ") .. ")")
+ else
+ return ("(" .. table.concat(operands, padded_native_name) .. ")")
+ end
+ end
+ end
+ end
+ local function define_bitop_special(name, zero_arity, unary_prefix, native)
+ local function _0_(...)
+ return bitop_special(native, name, zero_arity, unary_prefix, ...)
+ end
+ SPECIALS[name] = _0_
+ return nil
+ end
+ define_bitop_special("lshift", nil, "1", "<<")
+ define_bitop_special("rshift", nil, "1", ">>")
+ define_bitop_special("band", "0", "0", "&")
+ define_bitop_special("bor", "0", "0", "|")
+ define_bitop_special("bxor", "0", "0", "~")
+ doc_special("lshift", {"x", "n"}, "Bitwise logical left shift of x by n bits.\nOnly works in Lua 5.3+ or LuaJIT with the --use-bit-lib flag.")
+ doc_special("rshift", {"x", "n"}, "Bitwise logical right shift of x by n bits.\nOnly works in Lua 5.3+ or LuaJIT with the --use-bit-lib flag.")
+ doc_special("band", {"x1", "x2", "..."}, "Bitwise AND of any number of arguments.\nOnly works in Lua 5.3+ or LuaJIT with the --use-bit-lib flag.")
+ doc_special("bor", {"x1", "x2", "..."}, "Bitwise OR of any number of arguments.\nOnly works in Lua 5.3+ or LuaJIT with the --use-bit-lib flag.")
+ doc_special("bxor", {"x1", "x2", "..."}, "Bitwise XOR of any number of arguments.\nOnly works in Lua 5.3+ or LuaJIT with the --use-bit-lib flag.")
doc_special("..", {"a", "b", "..."}, "String concatenation operator; works the same as Lua but accepts more arguments.")
local function native_comparator(op, _0_0, scope, parent)
local _1_ = _0_0
@@ 3929,7 4341,6 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
define_comparator_special("<=")
define_comparator_special("=", "==")
define_comparator_special("not=", "~=", "or")
- SPECIALS["~="] = SPECIALS["not="]
local function define_unary_special(op, realop)
local function opfn(ast, scope, parent)
compiler.assert((#ast == 2), "expected one argument", ast)
@@ 3942,9 4353,10 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
define_unary_special("not", "not ")
doc_special("not", {"x"}, "Logical operator; works the same as Lua.")
define_unary_special("bnot", "~")
- doc_special("bnot", {"x"}, "Bitwise negation; only works in Lua 5.3+.")
+ doc_special("bnot", {"x"}, "Bitwise negation; only works in Lua 5.3+ or LuaJIT with the --use-bit-lib flag.")
define_unary_special("length", "#")
doc_special("length", {"x"}, "Returns the length of a table or string.")
+ SPECIALS["~="] = SPECIALS["not="]
SPECIALS["#"] = SPECIALS.length
SPECIALS.quote = function(ast, scope, parent)
compiler.assert((#ast == 2), "expected one argument")
@@ 3958,8 4370,9 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
return compiler["do-quote"](ast[2], scope, parent, runtime)
end
doc_special("quote", {"x"}, "Quasiquote the following form. Only works in macro/compiler scope.")
- local already_warned_3f = {}
- local compile_env_warning = ("WARNING: Attempting to %s %s in compile" .. " scope.\nIn future versions of Fennel this will not" .. " be allowed without the\n--no-compiler-sandbox flag" .. " or passing a :compilerEnv globals table in options.\n")
+ local macro_loaded = {}
+ local already_warned_3f = {_G = true}
+ local compile_env_warning = table.concat({"WARNING: Attempting to %s %s in compile scope.", "In future versions of Fennel this will not be allowed without the", "--no-compiler-sandbox flag or passing a :compilerEnv globals table", "in the options.\n"}, "\n")
local function compiler_env_warn(_, key)
local v = _G[key]
if (v and io and io.stderr and not already_warned_3f[key]) then
@@ 3977,44 4390,61 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
local function safe_compiler_env(strict_3f)
local _1_
if strict_3f then
- _1_ = compiler_env_warn
+ _1_ = nil
else
- _1_ = nil
+ _1_ = compiler_env_warn
end
return setmetatable({assert = assert, bit = rawget(_G, "bit"), error = error, getmetatable = safe_getmetatable, ipairs = ipairs, math = utils.copy(math), next = next, pairs = pairs, pcall = pcall, print = print, rawequal = rawequal, rawget = rawget, rawlen = rawget(_G, "rawlen"), rawset = rawset, require = safe_require, select = select, setmetatable = setmetatable, string = utils.copy(string), table = utils.copy(table), tonumber = tonumber, tostring = tostring, type = type, xpcall = xpcall}, {__index = _1_})
end
+ local function combined_mt_pairs(env)
+ local combined = {}
+ local _1_ = getmetatable(env)
+ local __index = _1_["__index"]
+ if ("table" == type(__index)) then
+ for k, v in pairs(__index) do
+ combined[k] = v
+ end
+ end
+ for k, v in next, env, nil do
+ combined[k] = v
+ end
+ return next, combined, nil
+ end
local function make_compiler_env(ast, scope, parent, strict_3f)
- local function _1_()
+ local provided = nil
+ do
+ local _1_0 = utils.root.options
+ if ((type(_1_0) == "table") and (_1_0["compiler-env"] == "strict")) then
+ provided = safe_compiler_env(true)
+ elseif ((type(_1_0) == "table") and (nil ~= _1_0.compilerEnv)) then
+ local compilerEnv = _1_0.compilerEnv
+ provided = compilerEnv
+ elseif ((type(_1_0) == "table") and (nil ~= _1_0["compiler-env"])) then
+ local compiler_env = _1_0["compiler-env"]
+ provided = compiler_env
+ else
+ local _ = _1_0
+ provided = safe_compiler_env(strict_3f)
+ end
+ end
+ local env = nil
+ local function _2_()
return compiler.scopes.macro
end
- local function _2_(symbol)
+ local function _3_(symbol)
compiler.assert(compiler.scopes.macro, "must call from macro", ast)
return compiler.scopes.macro.manglings[tostring(symbol)]
end
- local function _3_(base)
+ local function _4_(base)
return utils.sym(compiler.gensym((compiler.scopes.macro or scope), base))
end
- local function _4_(form)
+ local function _5_(form)
compiler.assert(compiler.scopes.macro, "must call from macro", ast)
return compiler.macroexpand(form, compiler.scopes.macro)
end
- local _6_
- do
- local _5_0 = utils.root.options
- if ((type(_5_0) == "table") and (_5_0["compiler-env"] == "strict")) then
- _6_ = safe_compiler_env(true)
- elseif ((type(_5_0) == "table") and (nil ~= _5_0.compilerEnv)) then
- local compilerEnv = _5_0.compilerEnv
- _6_ = compilerEnv
- elseif ((type(_5_0) == "table") and (nil ~= _5_0["compiler-env"])) then
- local compiler_env = _5_0["compiler-env"]
- _6_ = compiler_env
- else
- local _ = _5_0
- _6_ = safe_compiler_env(false)
- end
- end
- return setmetatable({["assert-compile"] = compiler.assert, ["get-scope"] = _1_, ["in-scope?"] = _2_, ["list?"] = utils["list?"], ["multi-sym?"] = utils["multi-sym?"], ["sequence?"] = utils["sequence?"], ["sym?"] = utils["sym?"], ["table?"] = utils["table?"], ["varg?"] = utils["varg?"], _AST = ast, _CHUNK = parent, _IS_COMPILER = true, _SCOPE = scope, _SPECIALS = compiler.scopes.global.specials, _VARARG = utils.varg(), gensym = _3_, list = utils.list, macroexpand = _4_, sequence = utils.sequence, sym = utils.sym, unpack = unpack, view = view}, {__index = _6_})
+ env = {["assert-compile"] = compiler.assert, ["get-scope"] = _2_, ["in-scope?"] = _3_, ["list?"] = utils["list?"], ["macro-loaded"] = macro_loaded, ["multi-sym?"] = utils["multi-sym?"], ["sequence?"] = utils["sequence?"], ["sym?"] = utils["sym?"], ["table?"] = utils["table?"], ["varg?"] = utils["varg?"], _AST = ast, _CHUNK = parent, _IS_COMPILER = true, _SCOPE = scope, _SPECIALS = compiler.scopes.global.specials, _VARARG = utils.varg(), gensym = _4_, list = utils.list, macroexpand = _5_, sequence = utils.sequence, sym = utils.sym, unpack = unpack, view = view}
+ env._G = env
+ return setmetatable(env, {__index = provided, __newindex = provided, __pairs = combined_mt_pairs})
end
local cfg = string.gmatch(package.config, "([^\n]+)")
local dirsep, pathsep, pathmark = (cfg() or "/"), (cfg() or ";"), (cfg() or "?")
@@ 4071,13 4501,56 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
end
return allowed
end
- local function compiler_env_domodule(modname, env, _3fast, _3fscope)
- local filename = compiler.assert(search_module(modname), (modname .. " module not found."), _3fast)
- local globals = macro_globals(env, current_global_names())
- local scope = (_3fscope or compiler["make-scope"](compiler.scopes.compiler))
- return utils["fennel-module"].dofile(filename, {allowedGlobals = globals, env = env, scope = scope, useMetadata = utils.root.options.useMetadata}, modname, filename)
+ local function fennel_macro_searcher(module_name)
+ local _1_0 = search_module(module_name, utils["fennel-module"]["macro-path"])
+ if (nil ~= _1_0) then
+ local filename = _1_0
+ local function _2_(...)
+ return utils["fennel-module"].dofile(filename, {env = "_COMPILER"}, ...)
+ end
+ return _2_, filename
+ end
+ end
+ local function lua_macro_searcher(module_name)
+ local _1_0 = search_module(module_name, package.path)
+ if (nil ~= _1_0) then
+ local filename = _1_0
+ local code = nil
+ do
+ local f = io.open(filename)
+ local function close_handlers_0_(ok_0_, ...)
+ f:close()
+ if ok_0_ then
+ return ...
+ else
+ return error(..., 0)
+ end
+ end
+ local function _2_()
+ return assert(f:read("*a"))
+ end
+ code = close_handlers_0_(xpcall(_2_, (package.loaded.fennel or debug).traceback))
+ end
+ local chunk = load_code(code, make_compiler_env(), filename)
+ return chunk, filename
+ end
+ end
+ local macro_searchers = {lua_macro_searcher, fennel_macro_searcher}
+ local function search_macro_module(modname, n)
+ local _1_0 = macro_searchers[n]
+ if (nil ~= _1_0) then
+ local f = _1_0
+ local _2_0, _3_0 = f(modname)
+ if ((nil ~= _2_0) and true) then
+ local loader = _2_0
+ local _3ffilename = _3_0
+ return loader, _3ffilename
+ else
+ local _ = _2_0
+ return search_macro_module(modname, (n + 1))
+ end
+ end
end
- local macro_loaded = {}
local function metadata_only_fennel(modname)
if ((modname == "fennel.macros") or (package and package.loaded and ("table" == type(package.loaded[modname])) and (package.loaded[modname].metadata == compiler.metadata))) then
return {metadata = compiler.metadata}
@@ 4085,11 4558,10 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
end
local function _1_(modname)
local function _2_()
- local scope = compiler["make-scope"](compiler.scopes.compiler)
- local env = make_compiler_env(nil, scope, nil)
- local mod = compiler_env_domodule(modname, env, nil, scope)
- macro_loaded[modname] = mod
- return mod
+ local loader, filename = search_macro_module(modname, 1)
+ compiler.assert(loader, (modname .. " module not found."))
+ macro_loaded[modname] = loader(modname, filename)
+ return macro_loaded[modname]
end
return (macro_loaded[modname] or metadata_only_fennel(modname) or _2_())
end
@@ 4105,12 4577,14 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
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)
+ local modname_chunk = load_code(compiler.compile(ast[2]), nil, filename)
+ local modname = modname_chunk(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)
+ local loader, filename0 = search_macro_module(modname, 1)
+ compiler.assert(loader, (modname .. " module not found."), ast)
+ macro_loaded[modname] = loader(modname, filename0)
end
return add_macros(macro_loaded[modname], ast, scope, parent)
end
@@ 4229,8 4703,8 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
ast[1] = old_first
return val
end
- doc_special("eval-compiler", {"..."}, "Evaluate the body at compile-time. Use the macro system instead if possible.")
- return {["current-global-names"] = current_global_names, ["load-code"] = load_code, ["macro-loaded"] = macro_loaded, ["make-compiler-env"] = make_compiler_env, ["make-searcher"] = make_searcher, ["search-module"] = search_module, ["wrap-env"] = wrap_env, doc = doc_2a}
+ doc_special("eval-compiler", {"..."}, "Evaluate the body at compile-time. Use the macro system instead if possible.", true)
+ return {["current-global-names"] = current_global_names, ["load-code"] = load_code, ["macro-loaded"] = macro_loaded, ["macro-searchers"] = macro_searchers, ["make-compiler-env"] = make_compiler_env, ["make-searcher"] = make_searcher, ["search-module"] = search_module, ["wrap-env"] = wrap_env, doc = doc_2a}
end
package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or function(...)
local utils = require("fennel.utils")
@@ 4246,7 4720,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
else
_0_ = 0
end
- return {autogensyms = {}, depth = _0_, hashfn = (parent0 and parent0.hashfn), includes = setmetatable({}, {__index = (parent0 and parent0.includes)}), macros = setmetatable({}, {__index = (parent0 and parent0.macros)}), manglings = setmetatable({}, {__index = (parent0 and parent0.manglings)}), parent = parent0, refedglobals = setmetatable({}, {__index = (parent0 and parent0.refedglobals)}), specials = setmetatable({}, {__index = (parent0 and parent0.specials)}), symmeta = setmetatable({}, {__index = (parent0 and parent0.symmeta)}), unmanglings = setmetatable({}, {__index = (parent0 and parent0.unmanglings)}), vararg = (parent0 and parent0.vararg)}
+ return {autogensyms = setmetatable({}, {__index = (parent0 and parent0.autogensyms)}), depth = _0_, gensyms = setmetatable({}, {__index = (parent0 and parent0.gensyms)}), hashfn = (parent0 and parent0.hashfn), includes = setmetatable({}, {__index = (parent0 and parent0.includes)}), macros = setmetatable({}, {__index = (parent0 and parent0.macros)}), manglings = setmetatable({}, {__index = (parent0 and parent0.manglings)}), parent = parent0, refedglobals = setmetatable({}, {__index = (parent0 and parent0.refedglobals)}), specials = setmetatable({}, {__index = (parent0 and parent0.specials)}), symmeta = setmetatable({}, {__index = (parent0 and parent0.symmeta)}), unmanglings = setmetatable({}, {__index = (parent0 and parent0.unmanglings)}), vararg = (parent0 and parent0.vararg)}
end
local function assert_msg(ast, msg)
local ast_tbl = nil
@@ 4320,11 4794,11 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
end
end
local allowed_globals = nil
- local function global_allowed(name)
+ local function global_allowed_3f(name)
return (not allowed_globals or utils["member?"](name, allowed_globals))
end
local function unique_mangling(original, mangling, scope, append)
- if scope.unmanglings[mangling] then
+ if (scope.unmanglings[mangling] and not scope.gensyms[mangling]) then
return unique_mangling(original, (original .. append), scope, (append + 1))
else
return mangling
@@ 4373,13 4847,17 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
end
return ret
end
- local function gensym(scope, base)
- local append, mangling = 0, ((base or "") .. "_0_")
+ local function next_append()
+ utils.root.scope["gensym-append"] = ((utils.root.scope["gensym-append"] or 0) + 1)
+ return ("_" .. utils.root.scope["gensym-append"] .. "_")
+ end
+ local function gensym(scope, base, _3fsuffix)
+ local mangling = ((base or "") .. next_append() .. (_3fsuffix or ""))
while scope.unmanglings[mangling] do
- mangling = ((base or "") .. "_" .. append .. "_")
- append = (append + 1)
+ mangling = ((base or "") .. next_append() .. (_3fsuffix or ""))
end
scope.unmanglings[mangling] = (base or true)
+ scope.gensyms[mangling] = true
return mangling
end
local function autogensym(base, scope)
@@ 4391,7 4869,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
else
local _ = _0_0
local function _1_()
- local mangling = gensym(scope, base:sub(1, ( - 2)))
+ local mangling = gensym(scope, base:sub(1, ( - 2)), "auto")
scope.autogensyms[base] = mangling
return mangling
end
@@ 4438,7 4916,8 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
if (local_3f and scope.symmeta[parts[1]]) then
scope.symmeta[parts[1]]["used"] = true
end
- assert_compile((not reference_3f or local_3f or global_allowed(parts[1])), ("unknown global in strict mode: " .. tostring(parts[1])), symbol)
+ assert_compile(not scope.macros[parts[1]], "tried to reference a macro at runtime", symbol)
+ assert_compile((not reference_3f or local_3f or ("_ENV" == parts[1]) or global_allowed_3f(parts[1])), ("unknown global in strict mode: " .. tostring(parts[1])), symbol)
if (allowed_globals and not local_3f) then
utils.root.scope.refedglobals[parts[1]] = true
end
@@ 4472,7 4951,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
local m = getmetatable(ast)
return ((m and m.line and m) or (("table" == type(ast)) and ast) or {})
end
- local function flatten_chunk_correlated(main_chunk)
+ local function flatten_chunk_correlated(main_chunk, options)
local function flatten(chunk, out, last_line, file)
local last_line0 = last_line
if chunk.leaf then
@@ 4481,7 4960,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
for _, subchunk in ipairs(chunk) do
if (subchunk.leaf or (#subchunk > 0)) then
local source = ast_source(subchunk.ast)
- if (file == source.file) then
+ if (file == source.filename) then
last_line0 = math.max(last_line0, (source.line or 0))
end
last_line0 = flatten(subchunk, out, last_line0, file)
@@ 4491,7 4970,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
return last_line0
end
local out = {}
- local last = flatten(main_chunk, out, 1, main_chunk.file)
+ local last = flatten(main_chunk, out, 1, options.filename)
for i = 1, last do
if (out[i] == nil) then
out[i] = ""
@@ 4548,7 5027,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
local function flatten(chunk, options)
local chunk0 = peephole(chunk)
if options.correlate then
- return flatten_chunk_correlated(chunk0), {}
+ return flatten_chunk_correlated(chunk0, options), {}
else
local sm = {}
local ret = flatten_chunk(sm, chunk0, options.indent, 0)
@@ 4600,7 5079,13 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
emit(chunk, string.format("do local _ = %s end", tostring(se)), ast)
elseif (se.type == "statement") then
local code = tostring(se)
- emit(chunk, (((code:byte() == 40) and ("do end " .. code)) or code), ast)
+ local disambiguated = nil
+ if (code:byte() == 40) then
+ disambiguated = ("do end " .. code)
+ else
+ disambiguated = code
+ end
+ emit(chunk, disambiguated, ast)
end
end
return nil
@@ 4662,26 5147,35 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
end
end
local function macroexpand_2a(ast, scope, once)
- if not utils["list?"](ast) then
- return ast
+ local _0_0 = nil
+ if utils["list?"](ast) then
+ _0_0 = find_macro(ast, scope, utils["multi-sym?"](ast[1]))
else
- local macro_2a = find_macro(ast, scope, utils["multi-sym?"](ast[1]))
- if not macro_2a then
- return ast
+ _0_0 = nil
+ end
+ if (_0_0 == false) then
+ return ast
+ elseif (nil ~= _0_0) then
+ local macro_2a = _0_0
+ local old_scope = scopes.macro
+ local _ = nil
+ scopes.macro = scope
+ _ = nil
+ local ok, transformed = nil, nil
+ local function _2_()
+ return macro_2a(unpack(ast, 2))
+ end
+ ok, transformed = xpcall(_2_, debug.traceback)
+ scopes.macro = old_scope
+ assert_compile(ok, transformed, ast)
+ if (once or not transformed) then
+ return transformed
else
- local old_scope = scopes.macro
- local _ = nil
- scopes.macro = scope
- _ = nil
- local ok, transformed = pcall(macro_2a, unpack(ast, 2))
- scopes.macro = old_scope
- assert_compile(ok, transformed, ast)
- if (once or not transformed) then
- return transformed
- else
- return macroexpand_2a(transformed, scope)
- end
+ return macroexpand_2a(transformed, scope)
end
+ else
+ local _ = _0_0
+ return ast
end
end
local function compile_special(ast, scope, parent, opts, special)
@@ 4709,7 5203,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
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)
+ assert_compile((("string" == type(ast[1])) or (fcallee.type ~= "literal")), ("cannot call literal value " .. tostring(ast[1])), ast)
for i = 2, len do
local subexprs = nil
local _0_
@@ 4728,7 5222,13 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
keep_side_effects(subexprs, parent, 2, ast[i])
end
end
- local call = string.format("%s(%s)", tostring(fcallee), exprs1(fargs))
+ local pat = nil
+ if ("string" == type(ast[1])) then
+ pat = "(%s)(%s)"
+ else
+ pat = "%s(%s)"
+ end
+ local call = string.format(pat, 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)
@@ 4743,7 5243,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
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, select(2, unpack(ast)))
+ local new_ast = utils.list(utils.sym(":", nil, scope), utils.sym(table_with_method, nil, scope), method_to_call, select(2, unpack(ast)))
return compile1(new_ast, scope, parent, opts)
else
return compile_function_call(ast, scope, parent, opts, compile1, len)
@@ 4814,9 5314,13 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
table.sort(_0_0, _1_)
keys = _0_0
end
- local function _1_(k)
- local v = tostring(compile1(ast[k[2]], scope, parent, {nval = 1})[1])
- return string.format("%s = %s", k[1], v)
+ local function _1_(_2_0)
+ local _3_ = _2_0
+ local k1 = _3_[1]
+ local k2 = _3_[2]
+ local _4_ = compile1(ast[k2], scope, parent, {nval = 1})
+ local v = _4_[1]
+ return string.format("%s = %s", k1, tostring(v))
end
utils.map(keys, _1_, buffer)
end
@@ 4846,8 5350,6 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
local forceglobal = _0_["forceglobal"]
local forceset = _0_["forceset"]
local isvar = _0_["isvar"]
- local nomulti = _0_["nomulti"]
- local noundef = _0_["noundef"]
local symtype = _0_["symtype"]
local symtype0 = ("_" .. (symtype or "dst"))
local setter = nil
@@ 4859,7 5361,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
local new_manglings = {}
local function getname(symbol, up1)
local raw = symbol[1]
- assert_compile(not (nomulti and utils["multi-sym?"](raw)), ("unexpected multi symbol " .. raw), up1)
+ assert_compile(not (opts0.nomulti and utils["multi-sym?"](raw)), ("unexpected multi symbol " .. raw), up1)
if declaration then
return declare_local(symbol, nil, scope, symbol, new_manglings)
else
@@ 4868,7 5370,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
if ((#parts == 1) and not forceset) then
assert_compile(not (forceglobal and meta), string.format("global %s conflicts with local", tostring(symbol)), symbol)
assert_compile(not (meta and not meta.var), ("expected var " .. raw), symbol)
- assert_compile((meta or not noundef), ("expected local " .. parts[1]), symbol)
+ assert_compile((meta or not opts0.noundef), ("expected local " .. parts[1]), symbol)
end
if forceglobal then
assert_compile(not scope.symmeta[scope.unmanglings[raw]], ("global " .. raw .. " conflicts with local"), symbol)
@@ 4903,6 5405,8 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
end
if ((#parent == (plen + 1)) and parent[#parent].leaf) then
parent[#parent]["leaf"] = ("local " .. parent[#parent].leaf)
+ elseif (init == "nil") then
+ table.insert(parent, (plen + 1), {ast = ast, leaf = ("local " .. lvalue)})
else
table.insert(parent, (plen + 1), {ast = ast, leaf = ("local " .. lvalue .. " = " .. init)})
end
@@ 4985,7 5489,9 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
compile_top_target(left_names)
if declaration then
for _, sym in ipairs(left) do
- scope.symmeta[utils.deref(sym)] = {var = isvar}
+ if utils["sym?"](sym) then
+ scope.symmeta[utils.deref(sym)] = {var = isvar}
+ end
end
end
for _, pair in utils.stablepairs(tables) do
@@ 5101,7 5607,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
end
end
local function traceback(msg, start)
- local msg0 = (msg or "")
+ local msg0 = tostring((msg or ""))
if ((msg0:find("^Compile error") or msg0:find("^Parse error")) and not utils["debug-on?"]("trace")) then
return msg0
else
@@ 5139,9 5645,6 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
end
return _0_
end
- local function no()
- return nil
- end
local function mixed_concat(t, joiner)
local seen = {}
local ret, s = "", ""
@@ 5175,16 5678,20 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
local symstr = utils.deref(form)
assert_compile(not runtime_3f, "symbols may only be used at compile time", form)
if (symstr:find("#$") or symstr:find("#[:.]")) then
- return string.format("sym('%s', nil, {filename=%s, line=%s})", autogensym(symstr, scope), filename, (form.line or "nil"))
+ return string.format("sym('%s', {filename=%s, line=%s})", autogensym(symstr, scope), filename, (form.line or "nil"))
else
- return string.format("sym('%s', nil, {quoted=true, filename=%s, line=%s})", symstr, filename, (form.line or "nil"))
+ return string.format("sym('%s', {quoted=true, filename=%s, line=%s})", symstr, filename, (form.line or "nil"))
end
elseif (utils["list?"](form) and utils["sym?"](form[1]) and (utils.deref(form[1]) == "unquote")) then
local payload = form[2]
local res = unpack(compile1(payload, scope, parent))
return res[1]
elseif utils["list?"](form) then
- local mapped = utils.kvmap(form, entry_transform(no, q))
+ local mapped = nil
+ local function _0_()
+ return nil
+ end
+ mapped = utils.kvmap(form, entry_transform(_0_, q))
local filename = nil
if form.filename then
filename = string.format("%q", form.filename)
@@ 5239,7 5746,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
local m = getmetatable(ast)
return ((m and m.line and m) or (("table" == type(ast)) and ast) or {})
end
- local suggestions = {["$ and $... in hashfn are mutually exclusive"] = {"modifying the hashfn so it only contains $... or $, $1, $2, $3, etc"}, ["can't start multisym segment with a digit"] = {"removing the digit", "adding a non-digit before the digit"}, ["cannot call literal value"] = {"checking for typos", "checking for a missing function name"}, ["could not compile value of type "] = {"debugging the macro you're calling to return a list or table"}, ["could not read number (.*)"] = {"removing the non-digit character", "beginning the identifier with a non-digit if it is not meant to be a number"}, ["expected a function.* to call"] = {"removing the empty parentheses", "using square brackets if you want an empty table"}, ["expected binding table"] = {"placing a table here in square brackets containing identifiers to bind"}, ["expected body expression"] = {"putting some code in the body of this form after the bindings"}, ["expected each macro to be function"] = {"ensuring that the value for each key in your macros table contains a function", "avoid defining nested macro tables"}, ["expected even number of name/value bindings"] = {"finding where the identifier or value is missing"}, ["expected even number of values in table literal"] = {"removing a key", "adding a value"}, ["expected local"] = {"looking for a typo", "looking for a local which is used out of its scope"}, ["expected macros to be table"] = {"ensuring your macro definitions return a table"}, ["expected parameters"] = {"adding function parameters as a list of identifiers in brackets"}, ["expected rest argument before last parameter"] = {"moving & to right before the final identifier when destructuring"}, ["expected symbol for function parameter: (.*)"] = {"changing %s to an identifier instead of a literal value"}, ["expected var (.*)"] = {"declaring %s using var instead of let/local", "introducing a new local instead of changing the value of %s"}, ["expected vararg as last parameter"] = {"moving the \"...\" to the end of the parameter list"}, ["expected whitespace before opening delimiter"] = {"adding whitespace"}, ["global (.*) conflicts with local"] = {"renaming local %s"}, ["illegal character: (.)"] = {"deleting or replacing %s", "avoiding reserved characters like \", \\, ', ~, ;, @, `, and comma"}, ["local (.*) was overshadowed by a special form or macro"] = {"renaming local %s"}, ["macro not found in macro module"] = {"checking the keys of the imported macro module's returned table"}, ["macro tried to bind (.*) without gensym"] = {"changing to %s# when introducing identifiers inside macros"}, ["malformed multisym"] = {"ensuring each period or colon is not followed by another period or colon"}, ["may only be used at compile time"] = {"moving this to inside a macro if you need to manipulate symbols/lists", "using square brackets instead of parens to construct a table"}, ["method must be last component"] = {"using a period instead of a colon for field access", "removing segments after the colon", "making the method call, then looking up the field on the result"}, ["mismatched closing delimiter (.), expected (.)"] = {"replacing %s with %s", "deleting %s", "adding matching opening delimiter earlier"}, ["multisym method calls may only be in call position"] = {"using a period instead of a colon to reference a table's fields", "putting parens around this"}, ["unable to bind (.*)"] = {"replacing the %s with an identifier"}, ["unexpected closing delimiter (.)"] = {"deleting %s", "adding matching opening delimiter earlier"}, ["unexpected multi symbol (.*)"] = {"removing periods or colons from %s"}, ["unexpected vararg"] = {"putting \"...\" at the end of the fn parameters if the vararg was intended"}, ["unknown global in strict mode: (.*)"] = {"looking to see if there's a typo", "using the _G table instead, eg. _G.%s if you really want a global", "moving this code to somewhere that %s is in scope", "binding %s as a local in the scope of this code"}, ["unused local (.*)"] = {"fixing a typo so %s is used", "renaming the local to _%s"}, ["use of global (.*) is aliased by a local"] = {"renaming local %s", "refer to the global using _G.%s instead of directly"}}
+ local suggestions = {["$ and $... in hashfn are mutually exclusive"] = {"modifying the hashfn so it only contains $... or $, $1, $2, $3, etc"}, ["can't start multisym segment with a digit"] = {"removing the digit", "adding a non-digit before the digit"}, ["cannot call literal value"] = {"checking for typos", "checking for a missing function name"}, ["could not compile value of type "] = {"debugging the macro you're calling to return a list or table"}, ["could not read number (.*)"] = {"removing the non-digit character", "beginning the identifier with a non-digit if it is not meant to be a number"}, ["expected a function.* to call"] = {"removing the empty parentheses", "using square brackets if you want an empty table"}, ["expected binding and iterator"] = {"making sure you haven't omitted a local name or iterator"}, ["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"}, ["tried to reference a macro at runtime"] = {"renaming the macro so as not to conflict with locals"}, ["unable to bind (.*)"] = {"replacing the %s with an identifier"}, ["unexpected closing delimiter (.)"] = {"deleting %s", "adding matching opening delimiter earlier"}, ["unexpected multi symbol (.*)"] = {"removing periods or colons from %s"}, ["unexpected vararg"] = {"putting \"...\" at the end of the fn parameters if the vararg was intended"}, ["unknown global in strict mode: (.*)"] = {"looking to see if there's a typo", "using the _G table instead, eg. _G.%s if you really want a global", "moving this code to somewhere that %s is in scope", "binding %s as a local in the scope of this code"}, ["unused local (.*)"] = {"fixing a typo so %s is used", "renaming the local to _%s"}, ["use of global (.*) is aliased by a local"] = {"renaming local %s", "refer to the global using _G.%s instead of directly"}}
local unpack = (table.unpack or _G.unpack)
local function suggest(msg)
local suggestion = nil
@@ 5504,23 6011,37 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
end
return dispatch(val)
end
- local function extract_comments(tbl)
- local comments = nil
- local _0_
- if utils["comment?"](tbl[#tbl]) then
- _0_ = table.remove(tbl)
+ local function add_comment_at(comments, index, node)
+ local _0_0 = comments[index]
+ if (nil ~= _0_0) then
+ local existing = _0_0
+ return table.insert(existing, node)
else
- _0_ = nil
+ local _ = _0_0
+ comments[index] = {node}
+ return nil
+ end
+ end
+ local function next_noncomment(tbl, i)
+ if utils["comment?"](tbl[i]) then
+ return next_noncomment(tbl, (i + 1))
+ else
+ return tbl[i]
+ end
+ end
+ local function extract_comments(tbl)
+ local comments = {keys = {}, last = {}, values = {}}
+ while utils["comment?"](tbl[#tbl]) do
+ table.insert(comments.last, 1, table.remove(tbl))
end
- comments = {keys = {}, last = _0_, values = {}}
local last_key_3f = false
for i, node in ipairs(tbl) do
if not utils["comment?"](node) then
last_key_3f = not last_key_3f
elseif last_key_3f then
- comments.values[tbl[(i + 1)]] = node
+ add_comment_at(comments.values, next_noncomment(tbl, i), node)
else
- comments.keys[tbl[(i + 1)]] = node
+ add_comment_at(comments.keys, next_noncomment(tbl, i), node)
end
end
for i = #tbl, 1, -1 do
@@ 5599,8 6120,13 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
table.remove(stack)
local raw = string.char(unpack(chars))
local formatted = raw:gsub("[\7-\13]", escape_char)
- local load_fn = (rawget(_G, "loadstring") or load)(("return " .. formatted))
- return dispatch(load_fn())
+ local _1_0 = (rawget(_G, "loadstring") or load)(("return " .. formatted))
+ if (nil ~= _1_0) then
+ local load_fn = _1_0
+ return dispatch(load_fn())
+ elseif (_1_0 == nil) then
+ return parse_error(("Invalid string: " .. raw))
+ end
end
local function parse_prefix(b)
table.insert(stack, {bytestart = byteindex, filename = filename, line = line, prefix = prefixes[b]})
@@ 5646,11 6172,13 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
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))
+ 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(":.+[%.:]")))
+ return parse_error(("method must be last component of multisym: " .. rawstr), ((byteindex - #rawstr) + rawstr:find(":.+[%.:]")))
+ else
+ return rawstr
end
end
local function parse_sym(b)
@@ 5664,12 6192,8 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
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}))
+ elseif not parse_number(rawstr) then
+ return dispatch(utils.sym(check_malformed_sym(rawstr), {byteend = byteindex, bytestart = bytestart, filename = filename, line = line}))
end
end
local function parse_loop(b)
@@ 5715,8 6239,8 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
for k in pairs(t) do
table.insert(keys, k)
end
- local function _0_(a, b)
- return (tostring(a) < tostring(b))
+ local function _0_(_241, _242)
+ return (tostring(_241) < tostring(_242))
end
table.sort(keys, _0_)
for i, k in ipairs(keys) do
@@ 5745,9 6269,8 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
if (type(f) == "function") then
f0 = f
else
- local s = f
- local function _0_(x)
- return x[s]
+ local function _0_(_241)
+ return _241[f]
end
f0 = _0_
end
@@ 5766,9 6289,8 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
if (type(f) == "function") then
f0 = f
else
- local s = f
- local function _0_(x)
- return x[s]
+ local function _0_(_241)
+ return _241[f]
end
f0 = _0_
end
@@ 5797,7 6319,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
if (_0_0 == x) then
return true
elseif (_0_0 == nil) then
- return false
+ return nil
else
local _ = _0_0
return member_3f(x, tbl, ((n or 1) + 1))
@@ 5815,10 6337,13 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
seen[next_state] = true
return next_state, value
else
- local meta = getmetatable(t)
- if (meta and meta.__index) then
- t = meta.__index
- return allpairs_next(t)
+ local _0_0 = getmetatable(t)
+ if ((type(_0_0) == "table") and (nil ~= _0_0.__index)) then
+ local __index = _0_0.__index
+ if ("table" == type(__index)) then
+ t = __index
+ return allpairs_next(t)
+ end
end
end
end
@@ 5867,9 6392,9 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
local function list(...)
return setmetatable({...}, list_mt)
end
- local function sym(str, scope, source)
- local s = {str, scope = scope}
- for k, v in pairs((source or {})) do
+ local function sym(str, _3fsource, _3fscope)
+ local s = {str, ["?scope"] = _3fscope}
+ for k, v in pairs((_3fsource or {})) do
if (type(k) == "string") then
s[k] = v
end
@@ 5883,8 6408,8 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
local function expr(strcode, etype)
return setmetatable({strcode, type = etype}, expr_mt)
end
- local function comment_2a(contents, source)
- local _1_ = (source or {})
+ local function comment_2a(contents, _3fsource)
+ local _1_ = (_3fsource or {})
local filename = _1_["filename"]
local line = _1_["line"]
return setmetatable({contents, filename = filename, line = line}, comment_mt)
@@ 5904,9 6429,6 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
local function sym_3f(x)
return ((type(x) == "table") and (getmetatable(x) == symbol_mt) and x)
end
- local function table_3f(x)
- return ((type(x) == "table") and (x ~= vararg) and (getmetatable(x) ~= list_mt) and (getmetatable(x) ~= symbol_mt) and x)
- end
local function sequence_3f(x)
local mt = ((type(x) == "table") and getmetatable(x))
return (mt and (mt.sequence == sequence_marker) and x)
@@ 5914,6 6436,9 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
local function comment_3f(x)
return ((type(x) == "table") and (getmetatable(x) == comment_mt) and x)
end
+ local function table_3f(x)
+ return ((type(x) == "table") and (x ~= vararg) and (getmetatable(x) ~= list_mt) and (getmetatable(x) ~= symbol_mt) and not comment_3f(x) and x)
+ end
local function multi_sym_3f(str)
if sym_3f(str) then
return multi_sym_3f(tostring(str))
@@ 5992,7 6517,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
return nil
end
end
- return {["comment?"] = comment_3f, ["debug-on?"] = debug_on_3f, ["expr?"] = expr_3f, ["list?"] = list_3f, ["lua-keywords"] = lua_keywords, ["member?"] = member_3f, ["multi-sym?"] = multi_sym_3f, ["propagate-options"] = propagate_options, ["quoted?"] = quoted_3f, ["sequence?"] = sequence_3f, ["sym?"] = sym_3f, ["table?"] = table_3f, ["valid-lua-identifier?"] = valid_lua_identifier_3f, ["varg?"] = varg_3f, ["walk-tree"] = walk_tree, allpairs = allpairs, comment = comment_2a, copy = copy, deref = deref, expr = expr, hook = hook, kvmap = kvmap, list = list, map = map, path = table.concat({"./?.fnl", "./?/init.fnl", getenv("FENNEL_PATH")}, ";"), root = root, sequence = sequence, stablepairs = stablepairs, sym = sym, varg = varg}
+ return {["comment?"] = comment_3f, ["debug-on?"] = debug_on_3f, ["expr?"] = expr_3f, ["list?"] = list_3f, ["lua-keywords"] = lua_keywords, ["macro-path"] = table.concat({"./?.fnl", "./?/init-macros.fnl", "./?/init.fnl", getenv("FENNEL_MACRO_PATH")}, ";"), ["member?"] = member_3f, ["multi-sym?"] = multi_sym_3f, ["propagate-options"] = propagate_options, ["quoted?"] = quoted_3f, ["sequence?"] = sequence_3f, ["sym?"] = sym_3f, ["table?"] = table_3f, ["valid-lua-identifier?"] = valid_lua_identifier_3f, ["varg?"] = varg_3f, ["walk-tree"] = walk_tree, allpairs = allpairs, comment = comment_2a, copy = copy, deref = deref, expr = expr, hook = hook, kvmap = kvmap, list = list, map = map, path = table.concat({"./?.fnl", "./?/init.fnl", getenv("FENNEL_PATH")}, ";"), root = root, sequence = sequence, stablepairs = stablepairs, sym = sym, varg = varg}
end
utils = require("fennel.utils")
local parser = require("fennel.parser")
@@ 6000,11 6525,12 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
local specials = require("fennel.specials")
local repl = require("fennel.repl")
local view = require("fennel.view")
- local function eval_env(env)
+ local function eval_env(env, opts)
if (env == "_COMPILER") then
local env0 = specials["make-compiler-env"](nil, compiler.scopes.compiler, {})
- local mt = getmetatable(env0)
- mt.__index = _G
+ if (opts.allowedGlobals == nil) then
+ opts.allowedGlobals = specials["current-global-names"](env0)
+ end
return specials["wrap-env"](env0)
else
return (env and specials["wrap-env"](env))
@@ 6012,17 6538,20 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
end
local function eval_opts(options, str)
local opts = utils.copy(options)
- if ((opts.allowedGlobals == nil) and not getmetatable(opts.env)) then
+ if (opts.allowedGlobals == nil) then
opts.allowedGlobals = specials["current-global-names"](opts.env)
end
if (not opts.filename and not opts.source) then
opts.source = str
end
+ if (opts.env == "_COMPILER") then
+ opts.scope = compiler["make-scope"](compiler.scopes.compiler)
+ end
return opts
end
local function eval(str, options, ...)
local opts = eval_opts(options, str)
- local env = eval_env(opts.env)
+ local env = eval_env(opts.env, opts)
local lua_source = compiler["compile-string"](str, opts)
local loader = nil
local function _0_(...)
@@ 6044,7 6573,34 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
opts.filename = filename
return eval(source, opts, ...)
end
- local mod = {["comment?"] = utils["comment?"], ["compile-stream"] = compiler["compile-stream"], ["compile-string"] = compiler["compile-string"], ["list?"] = utils["list?"], ["load-code"] = specials["load-code"], ["macro-loaded"] = specials["macro-loaded"], ["make-searcher"] = specials["make-searcher"], ["search-module"] = specials["search-module"], ["sequence?"] = utils["sequence?"], ["string-stream"] = parser["string-stream"], ["sym-char?"] = parser["sym-char?"], ["sym?"] = utils["sym?"], comment = utils.comment, compile = compiler.compile, compile1 = compiler.compile1, compileStream = compiler["compile-stream"], compileString = compiler["compile-string"], doc = specials.doc, dofile = dofile_2a, eval = eval, gensym = compiler.gensym, granulate = parser.granulate, list = utils.list, loadCode = specials["load-code"], macroLoaded = specials["macro-loaded"], makeSearcher = specials["make-searcher"], make_searcher = specials["make-searcher"], mangle = compiler["global-mangling"], metadata = compiler.metadata, parser = parser.parser, path = utils.path, repl = repl, scope = compiler["make-scope"], searchModule = specials["search-module"], searcher = specials["make-searcher"](), sequence = utils.sequence, stringStream = parser["string-stream"], sym = utils.sym, traceback = compiler.traceback, unmangle = compiler["global-unmangling"], varg = utils.varg, version = "0.8.2-dev", view = view}
+ local function syntax()
+ local body_3f = {"when", "with-open", "collect", "icollect", "lambda", "\206\187", "macro", "match"}
+ local binding_3f = {"collect", "icollect", "each", "for", "let", "with-open"}
+ local define_3f = {"fn", "lambda", "\206\187", "var", "local", "macro", "macros", "global"}
+ local out = {}
+ for k, v in pairs(compiler.scopes.global.specials) do
+ local metadata = (compiler.metadata[v] or {})
+ out[k] = {["binding-form?"] = utils["member?"](k, binding_3f), ["body-form?"] = metadata["fnl/body-form?"], ["define?"] = utils["member?"](k, define_3f), ["special?"] = true}
+ end
+ for k, v in pairs(compiler.scopes.global.macros) do
+ out[k] = {["binding-form?"] = utils["member?"](k, binding_3f), ["body-form?"] = utils["member?"](k, body_3f), ["define?"] = utils["member?"](k, define_3f), ["macro?"] = true}
+ end
+ for k, v in pairs(_G) do
+ local _0_0 = type(v)
+ if (_0_0 == "function") then
+ out[k] = {["function?"] = true, ["global?"] = true}
+ elseif (_0_0 == "table") then
+ for k2, v2 in pairs(v) do
+ if (("function" == type(v2)) and (k ~= "_G")) then
+ out[(k .. "." .. k2)] = {["function?"] = true, ["global?"] = true}
+ end
+ end
+ out[k] = {["global?"] = true}
+ end
+ end
+ return out
+ end
+ local mod = {["comment?"] = utils["comment?"], ["compile-stream"] = compiler["compile-stream"], ["compile-string"] = compiler["compile-string"], ["list?"] = utils["list?"], ["load-code"] = specials["load-code"], ["macro-loaded"] = specials["macro-loaded"], ["macro-path"] = utils["macro-path"], ["macro-searchers"] = specials["macro-searchers"], ["make-searcher"] = specials["make-searcher"], ["search-module"] = specials["search-module"], ["sequence?"] = utils["sequence?"], ["string-stream"] = parser["string-stream"], ["sym-char?"] = parser["sym-char?"], ["sym?"] = utils["sym?"], comment = utils.comment, compile = compiler.compile, compile1 = compiler.compile1, compileStream = compiler["compile-stream"], compileString = compiler["compile-string"], doc = specials.doc, dofile = dofile_2a, eval = eval, gensym = compiler.gensym, granulate = parser.granulate, list = utils.list, loadCode = specials["load-code"], macroLoaded = specials["macro-loaded"], makeSearcher = specials["make-searcher"], make_searcher = specials["make-searcher"], mangle = compiler["global-mangling"], metadata = compiler.metadata, parser = parser.parser, path = utils.path, repl = repl, scope = compiler["make-scope"], searchModule = specials["search-module"], searcher = specials["make-searcher"](), sequence = utils.sequence, stringStream = parser["string-stream"], sym = utils.sym, syntax = syntax, traceback = compiler.traceback, unmangle = compiler["global-unmangling"], varg = utils.varg, version = "0.10.0-dev", view = view}
utils["fennel-module"] = mod
do
local builtin_macros = [===[;; This module contains all the built-in Fennel macros. Unlike all the other
@@ 6109,13 6665,18 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
(-?>> ,el ,(unpack els))
,tmp)))))
- (fn ?dot [tbl k ...]
+ (fn ?dot [tbl ...]
"Nil-safe table look up.
Same as . (dot), except will short-circuit with nil when it encounters
a nil value in any of subsequent keys."
- (if (= nil k) tbl
- `(let [res# (. ,tbl ,k)]
- (and res# (?. res# ,...)))))
+ (let [head (gensym :t)
+ lookups `(do (var ,head ,tbl) ,head)]
+ (each [_ k (ipairs [...])]
+ ;; Kinda gnarly to reassign in place like this, but it emits the best lua.
+ ;; With this impl, it emits a flat, concise, and readable set of if blocks.
+ (table.insert lookups (# lookups) `(if (not= nil ,head)
+ (set ,head (. ,head ,k)))))
+ lookups))
(fn doto* [val ...]
"Evaluates val and splices it into the first argument of subsequent forms."
@@ 6131,22 6692,26 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
"Evaluate body for side-effects only when condition is truthy."
(assert body1 "expected body")
`(if ,condition
- (do ,body1 ,...)))
+ (do
+ ,body1
+ ,...)))
(fn with-open* [closable-bindings ...]
"Like `let`, but invokes (v:close) on each binding after evaluating the body.
The body is evaluated inside `xpcall` so that bound values will be closed upon
encountering an error before propagating it."
- (let [bodyfn `(fn [] ,...)
- closer `(fn close-handlers# [ok# ...] (if ok# ...
- (error ... 0)))
+ (let [bodyfn `(fn []
+ ,...)
+ closer `(fn close-handlers# [ok# ...]
+ (if ok# ... (error ... 0)))
traceback `(. (or package.loaded.fennel debug) :traceback)]
- (for [i 1 (# closable-bindings) 2]
+ (for [i 1 (length closable-bindings) 2]
(assert (sym? (. closable-bindings i))
"with-open only allows symbols in bindings")
(table.insert closer 4 `(: ,(. closable-bindings i) :close)))
- `(let ,closable-bindings ,closer
- (close-handlers# (xpcall ,bodyfn ,traceback)))))
+ `(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
@@ 6161,8 6726,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
{:red \"apple\" :orange \"orange\"}"
(assert (and (sequence? iter-tbl) (>= (length iter-tbl) 2))
"expected iterator binding table")
- (assert (not= nil key-value-expr)
- "expected key-value expression")
+ (assert (not= nil key-value-expr) "expected key-value expression")
(assert (= nil ...)
"expected exactly one body expression. Wrap multiple expressions with do")
`(let [tbl# {}]
@@ 6182,8 6746,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
[9 16 25]"
(assert (and (sequence? iter-tbl) (>= (length iter-tbl) 2))
"expected iterator binding table")
- (assert (not= nil value-expr)
- "expected table value expression")
+ (assert (not= nil value-expr) "expected table value expression")
(assert (= nil ...)
"expected exactly one body expression. Wrap multiple expressions with do")
`(let [tbl# []]
@@ 6191,12 6754,54 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
(tset tbl# (+ (length tbl#) 1) ,value-expr))
tbl#))
+ (fn accumulate* [iter-tbl accum-expr ...]
+ "Accumulation macro.
+ It takes a binding table and an expression as its arguments.
+ In the binding table, the first symbol is bound to the second value, being an
+ initial accumulator variable. The rest are an iterator binding table in the
+ format `each` takes.
+ It runs through the iterator in each step of which the given expression is
+ evaluated, and its returned value updates the accumulator variable.
+ It eventually returns the final value of the accumulator variable.
+
+ For example,
+ (accumulate [total 0
+ _ n (pairs {:apple 2 :orange 3})]
+ (+ total n))
+ returns
+ 5"
+ (assert (and (sequence? iter-tbl) (>= (length iter-tbl) 4))
+ "expected initial value and iterator binding table")
+ (assert (not= nil accum-expr) "expected accumulating expression")
+ (assert (= nil ...)
+ "expected exactly one body expression. Wrap multiple expressions with do")
+ (let [accum-var (table.remove iter-tbl 1)
+ accum-init (table.remove iter-tbl 1)]
+ `(do (var ,accum-var ,accum-init)
+ (each ,iter-tbl
+ (set ,accum-var ,accum-expr))
+ ,accum-var)))
+
(fn partial* [f ...]
"Returns a function with all arguments partially applied to f."
(assert f "expected a function to partially apply")
- (let [body (list f ...)]
- (table.insert body _VARARG)
- `(fn [,_VARARG] ,body)))
+ (let [bindings []
+ args []]
+ (each [_ arg (ipairs [...])]
+ (if (or (= :number (type arg))
+ (= :string (type arg))
+ (= :boolean (type arg))
+ (= `nil arg))
+ (table.insert args arg)
+ (let [name (gensym)]
+ (table.insert bindings name)
+ (table.insert bindings arg)
+ (table.insert args name))))
+ (let [body (list f (unpack args))]
+ (table.insert body _VARARG)
+ `(let ,bindings
+ (fn [,_VARARG]
+ ,body)))))
(fn pick-args* [n f]
"Creates a function of arity n that applies its arguments to f.
@@ 6205,11 6810,16 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
(pick-args 2 func)
expands to
(fn [_0_ _1_] (func _0_ _1_))"
+ (if (and _G.io _G.io.stderr)
+ (_G.io.stderr:write
+ "-- WARNING: pick-args is deprecated and will be removed in the future.\n"))
(assert (and (= (type n) :number) (= n (math.floor n)) (>= n 0))
(.. "Expected n to be an integer literal >= 0, got " (tostring n)))
(let [bindings []]
- (for [i 1 n] (tset bindings i (gensym)))
- `(fn ,bindings (,f ,(unpack bindings)))))
+ (for [i 1 n]
+ (tset bindings i (gensym)))
+ `(fn ,bindings
+ (,f ,(unpack bindings)))))
(fn pick-values* [n ...]
"Like the `values` special, but emits exactly n values.
@@ 6221,11 6831,13 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
(values _0_ _1_))"
(assert (and (= :number (type n)) (>= n 0) (= n (math.floor n)))
(.. "Expected n to be an integer >= 0, got " (tostring n)))
- (let [let-syms (list)
- let-values (if (= 1 (select :# ...)) ... `(values ,...))]
- (for [i 1 n] (table.insert let-syms (gensym)))
+ (let [let-syms (list)
+ let-values (if (= 1 (select "#" ...)) ... `(values ,...))]
+ (for [i 1 n]
+ (table.insert let-syms (gensym)))
(if (= n 0) `(values)
- `(let [,let-syms ,let-values] (values ,(unpack let-syms))))))
+ `(let [,let-syms ,let-values]
+ (values ,(unpack let-syms))))))
(fn lambda* [...]
"Function literal with arity checking.
@@ 6235,23 6847,25 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
has-internal-name? (sym? (. args 1))
arglist (if has-internal-name? (. args 2) (. args 1))
docstring-position (if has-internal-name? 3 2)
- has-docstring? (and (> (# args) docstring-position)
+ has-docstring? (and (> (length args) docstring-position)
(= :string (type (. args docstring-position))))
arity-check-position (- 4 (if has-internal-name? 0 1)
(if has-docstring? 0 1))
- empty-body? (< (# args) arity-check-position)]
+ empty-body? (< (length args) arity-check-position)]
(fn check! [a]
(if (table? a)
(each [_ a (pairs a)]
(check! a))
(let [as (tostring a)]
- (and (not (as:match "^?")) (not= as "&") (not= as "_") (not= as "...")))
+ (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"
,(tostring a)
- ,(or a.filename "unknown")
+ ,(or a.filename :unknown)
,(or a.line "?"))))))
+
(assert (= :table (type arglist)) "expected arg list")
(each [_ a (ipairs arglist)]
(check! a))
@@ 6263,7 6877,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 ,(unpack args))}))
+ `(macros {,(tostring name) (fn ,(unpack args))}))
(fn macrodebug* [form return?]
"Print the resulting form after performing macroexpansion.
@@ 6277,9 6891,9 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
Example:
(import-macros mymacros :my-macros ; bind to symbol
{:macro1 alias : macro2} :proj.macros) ; import by name"
- (assert (and binding1 module-name1 (= 0 (% (select :# ...) 2)))
+ (assert (and binding1 module-name1 (= 0 (% (select "#" ...) 2)))
"expected even number of binding/modulename pairs")
- (for [i 1 (select :# binding1 module-name1 ...) 2]
+ (for [i 1 (select "#" binding1 module-name1 ...) 2]
(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
@@ 6289,10 6903,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
(_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)))
-
+ (tset scope.macros (. binding 1) (. macro-loaded modname))
;; 1-level table destructuring for importing individual macros
(table? binding)
(each [macro-name [import-key] (pairs binding)]
@@ 6320,15 6931,25 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
bindings []]
(each [k pat (pairs pattern)]
(if (= pat `&)
- (do (assert (not (. pattern (+ k 2)))
- "expected rest argument before last parameter")
- (table.insert bindings (. pattern (+ k 1)))
- (table.insert bindings [`(select ,k ((or table.unpack
- _G.unpack)
- ,val))]))
- (and (= :number (type k))
- (= "&" (tostring (. pattern (- k 1)))))
- nil ; don't process the pattern right after &; already got it
+ (do
+ (assert (= nil (. pattern (+ k 2)))
+ "expected & rest argument before last parameter")
+ (table.insert bindings (. pattern (+ k 1)))
+ (table.insert bindings
+ [`(select ,k ((or table.unpack _G.unpack) ,val))]))
+ (= k `&as)
+ (do
+ (table.insert bindings pat)
+ (table.insert bindings val))
+ (and (= :number (type k)) (= `&as pat))
+ (do
+ (assert (= nil (. pattern (+ k 2)))
+ "expected &as argument before last parameter")
+ (table.insert bindings (. pattern (+ k 1)))
+ (table.insert bindings val))
+ ;; don't process the pattern right after &/&as; already got it
+ (or (not= :number (type k)) (and (not= `&as (. pattern (- k 1)))
+ (not= `& (. pattern (- k 1)))))
(let [subval `(. ,val ,k)
(subcondition subbindings) (match-pattern [subval] pat
unifications)]
@@ 6346,11 6967,9 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
;; of vals) or we're not, in which case we only care about the first one.
(let [[val] vals]
(if (or (and (sym? pattern) ; unification with outer locals (or nil)
- (not= :_ (tostring pattern)) ; never unify _
- (or (in-scope? pattern)
- (= :nil (tostring pattern))))
- (and (multi-sym? pattern)
- (in-scope? (. (multi-sym? pattern) 1))))
+ (not= "_" (tostring pattern)) ; never unify _
+ (or (in-scope? pattern) (= :nil (tostring pattern))))
+ (and (multi-sym? pattern) (in-scope? (. (multi-sym? pattern) 1))))
(values `(= ,val ,pattern) [])
;; unify a local we've seen already
(and (sym? pattern) (. unifications (tostring pattern)))
@@ 6359,18 6978,16 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
(sym? 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))
- [pattern val]))
+ (values (if (or wildcard? (string.find (tostring pattern) "^?")) true
+ `(not= ,(sym :nil) ,val)) [pattern val]))
;; guard clause
(and (list? pattern) (= (. pattern 2) `?))
(let [(pcondition bindings) (match-pattern vals (. pattern 1)
unifications)
- condition `(and ,pcondition)]
- (for [i 3 (# pattern)] ; splice in guard clauses
- (table.insert condition (. pattern i)))
- (values `(let ,bindings ,condition) bindings))
-
+ condition `(and ,(unpack pattern 3))]
+ (values `(and ,pcondition
+ (let ,bindings
+ ,condition)) bindings))
;; multi-valued patterns (represented as lists)
(list? pattern)
(match-values vals pattern unifications match-pattern)
@@ 6383,24 7000,28 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
(fn match-condition [vals clauses]
"Construct the actual `if` AST for the given match values and clauses."
(if (not= 0 (% (length clauses) 2)) ; treat odd final clause as default
- (table.insert clauses (length clauses) (sym :_)))
+ (table.insert clauses (length clauses) (sym "_")))
(let [out `(if)]
(for [i 1 (length clauses) 2]
(let [pattern (. clauses i)
body (. clauses (+ i 1))
(condition bindings) (match-pattern vals pattern {})]
(table.insert out condition)
- (table.insert out `(let ,bindings ,body))))
+ (table.insert out `(let ,bindings
+ ,body))))
out))
(fn match-val-syms [clauses]
"How many multi-valued clauses are there? return a list of that many gensyms."
(let [syms (list (gensym))]
(for [i 1 (length clauses) 2]
- (if (list? (. clauses i))
- (each [valnum (ipairs (. clauses i))]
- (if (not (. syms valnum))
- (tset syms valnum (gensym))))))
+ (let [clause (if (and (list? (. clauses i)) (= `? (. clauses i 2)))
+ (. clauses i 1)
+ (. clauses i))]
+ (if (list? clause)
+ (each [valnum (ipairs clause)]
+ (if (not (. syms valnum))
+ (tset syms valnum (gensym)))))))
syms))
(fn match* [val ...]
@@ 6411,8 7032,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
vals (match-val-syms clauses)]
;; protect against multiple evaluation of the value, bind against as
;; many values as we ever match against in the clauses.
- (list `let [vals val]
- (match-condition vals clauses))))
+ (list `let [vals val] (match-condition vals clauses))))
;; Construction of old match syntax from new syntax
@@ 6428,8 7048,8 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
(for [i 1 (length seq) 2]
(let [first (. seq i)
second (. seq (+ i 1))]
- (table.insert firsts (if (not= nil first) first 'nil))
- (table.insert seconds (if (not= nil second) second 'nil))))
+ (table.insert firsts (if (not= nil first) first `nil))
+ (table.insert seconds (if (not= nil second) second `nil))))
(each [i v1 (ipairs firsts)]
(let [v2 (. seconds i)]
(if (not= nil v2)
@@ 6442,7 7062,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
;; (or pat1 pat2), guard => [(pat1 ? guard) (pat2 ? guard)]
(let [res []]
(each [_ pat (ipairs pats)]
- (table.insert res (list pat '? (unpack guards))))
+ (table.insert res (list pat `? (unpack guards))))
res))
(fn transform-cond [cond]
@@ 6456,7 7076,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
(if (and (list? second) (= (. second 1) `or))
(transform-or second [(unpack cond 3)])
:else
- [(list second '? (unpack cond 3))]))
+ [(list second `? (unpack cond 3))]))
:else
[cond]))
@@ 6470,8 7090,8 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
(where pattern guard guards*) body
(where (or pattern patterns*) guard guards*) body)"
(let [conds-bodies (partition-2 [...])
- else-branch (if (not= 0 (% (select :# ...) 2))
- (select (select :# ...) ...))
+ else-branch (if (not= 0 (% (select "#" ...) 2))
+ (select (select "#" ...) ...))
match-body []]
(each [_ [cond body] (ipairs conds-bodies)]
(each [_ cond (ipairs (transform-cond cond))]
@@ 6481,12 7101,24 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
(table.insert match-body else-branch))
(match* val (unpack match-body))))
- {:-> ->* :->> ->>* :-?> -?>* :-?>> -?>>* :?. ?dot
- :doto doto* :when when* :with-open with-open*
- :collect collect* :icollect icollect*
- :partial partial* :lambda lambda*
- :pick-args pick-args* :pick-values pick-values*
- :macro macro* :macrodebug macrodebug* :import-macros import-macros*
+ {:-> ->*
+ :->> ->>*
+ :-?> -?>*
+ :-?>> -?>>*
+ :?. ?dot
+ :doto doto*
+ :when when*
+ :with-open with-open*
+ :collect collect*
+ :icollect icollect*
+ :accumulate accumulate*
+ :partial partial*
+ :lambda lambda*
+ :pick-args pick-args*
+ :pick-values pick-values*
+ :macro macro*
+ :macrodebug macrodebug*
+ :import-macros import-macros*
:match match-where}
]===]
local module_name = "fennel.macros"
@@ 6513,7 7145,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...)
return mod
end
fennel = require("fennel")
-local searcher = fennel.makeSearcher({})
+local searcher = fennel.makeSearcher({correlate = true})
debug.traceback = fennel.traceback
if os.getenv("FNL") then
table.insert((package.loaders or package.searchers), 1, searcher)
@@ 6527,7 7159,7 @@ local reader = require("lang.reader")
local compiler = require("anticompiler")
local letter = require("letter")
local fnlfmt = require("fnlfmt")
-local reserved_fennel = {}
+local reserved_fennel = {band = true, bnot = true, bor = true, bxor = true, doc = true, doto = true, each = true, fn = true, global = true, hashfn = true, lambda = true, let = true, lshift = true, lua = true, macro = true, macrodebug = true, macroexpand = true, macros = true, match = true, partial = true, rshift = true, set = true, tset = true, values = true, var = true, when = true}
local function uncamelize(name)
local function splicedash(pre, cap)
return (pre .. "-" .. cap:lower())
@@ 6561,12 7193,12 @@ if ((debug and debug.getinfo) and (debug.getinfo(3) == nil)) then
return os.exit(1)
end
else
- local function _1_(str, source)
+ local function _356_(str, source)
local out = {}
for _, code in ipairs(compile(reader.string(str), (source or "*source"))) do
table.insert(out, fnlfmt.fnlfmt(code))
end
return table.concat(out, "\n")
end
- return _1_
+ return _356_
end