From 1209203fe4ddd26ccf887175a5b3463c1385762b Mon Sep 17 00:00:00 2001 From: Phil Hagelberg Date: Thu, 8 Apr 2021 15:06:48 -0700 Subject: [PATCH] Update to Fennel 0.9.0 --- lib/fennel | 1060 +++++++++++++++++++++++++++++++----------------- lib/fennel.lua | 1053 ++++++++++++++++++++++++++++++----------------- 2 files changed, 1377 insertions(+), 736 deletions(-) diff --git a/lib/fennel b/lib/fennel index 1b9f8c3..aa74879 100755 --- a/lib/fennel +++ b/lib/fennel @@ -53,7 +53,7 @@ package.preload["fennel.binary"] = package.preload["fennel.binary"] or function( local fennel_loader = nil local _0_ do - _0_ = "(do (local bundle_0_ ...) (fn loader_0_ [name_0_] (match (or (. bundle_0_ name_0_) (. bundle_0_ (.. name_0_ \".init\"))) (mod_0_ ? (= \"function\" (type mod_0_))) mod_0_ (mod_0_ ? (= \"string\" (type mod_0_))) (assert (if (= _VERSION \"Lua 5.1\") (loadstring mod_0_ name_0_) (load mod_0_ name_0_))) nil (values nil (: \"\\\n\\9module '%%s' not found in fennel bundle\" \"format\" name_0_)))) (table.insert (or package.loaders package.searchers) 2 loader_0_) ((assert (loader_0_ \"%s\")) ((or unpack table.unpack) arg)))" + _0_ = "(do (local bundle_0_ ...) (fn loader_0_ [name_0_] (match (or (. bundle_0_ name_0_) (. bundle_0_ (.. name_0_ \".init\"))) (mod_0_ ? (= \"function\" (type mod_0_))) mod_0_ (mod_0_ ? (= \"string\" (type mod_0_))) (assert (if (= _VERSION \"Lua 5.1\") (loadstring mod_0_ name_0_) (load mod_0_ name_0_))) nil (values nil (: \"\n\\tmodule '%%s' not found in fennel bundle\" \"format\" name_0_)))) (table.insert (or package.loaders package.searchers) 2 loader_0_) ((assert (loader_0_ \"%s\")) ((or unpack table.unpack) arg)))" end fennel_loader = _0_:format(dotpath_noextension) local lua_loader = fennel["compile-string"](fennel_loader) @@ -474,12 +474,14 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) end local function table_kv_pairs(t) local assoc_3f = false + local i = 1 local kv = {} local insert = table.insert for k, v in pairs(t) do - if (type(k) ~= "number") then + if ((type(k) ~= "number") or (k ~= i)) then assoc_3f = true end + i = (i + 1) insert(kv, {k, v}) end table.sort(kv, sort_keys) @@ -519,21 +521,19 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) end return seen0 end - local function detect_cycle(t, seen) - local seen0 = (seen or {}) - seen0[t] = true - for k, v in pairs(t) do - if ((type(k) == "table") and (seen0[k] or detect_cycle(k, seen0))) then - return true - end - if ((type(v) == "table") and (seen0[v] or detect_cycle(v, seen0))) then - return true + local function detect_cycle(t, seen, _3fk) + if ("table" == type(t)) then + seen[t] = true + local _2_0, _3_0 = next(t, _3fk) + if ((nil ~= _2_0) and (nil ~= _3_0)) then + local k = _2_0 + local v = _3_0 + return (seen[k] or detect_cycle(k, seen) or seen[v] or detect_cycle(v, seen) or detect_cycle(t, seen, k)) end end - return nil end local function visible_cycle_3f(t, options) - return (options["detect-cycles?"] and detect_cycle(t) and save_table(t, options.seen) and (1 < (options.appearances[t] or 0))) + return (options["detect-cycles?"] and detect_cycle(t, {}) and save_table(t, options.seen) and (1 < (options.appearances[t] or 0))) end local function table_indent(t, indent, id) local opener_length = nil @@ -544,7 +544,7 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) end return (indent + opener_length) end - local pp = {} + local pp = nil local function concat_table_lines(elements, options, multiline_3f, indent, table_type, prefix) local indent_str = ("\n" .. string.rep(" ", indent)) local open = nil @@ -563,13 +563,7 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) close = "}" end local oneline = (open .. table.concat(elements, " ") .. close) - local _4_ - if (table_type == "seq") then - _4_ = options["sequential-length"] - else - _4_ = options["associative-length"] - end - if (not options["one-line?"] and (multiline_3f or (#elements > _4_) or ((indent + #oneline) > options["line-length"]))) then + if (not options["one-line?"] and (multiline_3f or ((indent + #oneline) > options["line-length"]))) then return (open .. table.concat(elements, indent_str) .. close) else return oneline @@ -605,7 +599,7 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) else prefix = "" end - local elements = nil + local items = nil do local tbl_0_ = {} for _, _6_0 in pairs(kv) do @@ -614,16 +608,16 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) local v = _7_[2] local _8_ do - local k0 = pp.pp(k, options, (indent0 + 1), true) - local v0 = pp.pp(v, options, (indent0 + slength(k0) + 1)) + local k0 = pp(k, options, (indent0 + 1), true) + local v0 = pp(v, options, (indent0 + slength(k0) + 1)) multiline_3f = (multiline_3f or k0:find("\n") or v0:find("\n")) _8_ = (k0 .. " " .. v0) 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) @@ -643,7 +637,7 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) else prefix = "" end - local elements = nil + local items = nil do local tbl_0_ = {} for _, _3_0 in pairs(kv) do @@ -652,15 +646,15 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) local v = _4_[2] local _5_ do - local v0 = pp.pp(v, options, indent0) + local v0 = pp(v, options, indent0) multiline_3f = (multiline_3f or v0:find("\n")) _5_ = v0 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) @@ -702,7 +696,7 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) end options["visible-cycle?"] = _2_ _ = nil - local lines, force_multi_line_3f = metamethod(t, pp.pp, options, indent) + local lines, force_multi_line_3f = metamethod(t, pp, options, indent) options["visible-cycle?"] = nil local _3_0 = type(lines) if (_3_0 == "string") then @@ -711,7 +705,7 @@ package.preload["fennel.view"] = package.preload["fennel.view"] 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 @@ -763,31 +757,28 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) return x0 end local function number__3estring(n) - local _2_0, _3_0, _4_0 = math.modf(n) - if ((nil ~= _2_0) and (_3_0 == 0)) then - local int = _2_0 - return tostring(int) - else - local _5_ - do - local frac = _3_0 - _5_ = (((_2_0 == 0) and (nil ~= _3_0)) and (frac < 0)) - end - if _5_ then - local frac = _3_0 - return ("-0." .. tostring(frac):gsub("^-?0.", "")) - elseif ((nil ~= _2_0) and (nil ~= _3_0)) then - local int = _2_0 - local frac = _3_0 - return (int .. "." .. tostring(frac):gsub("^-?0.", "")) - end - end + local _2_0 = string.gsub(tostring(n), ",", ".") + return _2_0 end local function colon_string_3f(s) - return s:find("^[-%w?\\^_!$%&*+./@:|<=>]+$") + return s:find("^[-%w?^_!$%&*+./@|<=>]+$") + end + local function pp_string(str, options, indent) + local escs = nil + local _2_ + if (options["escape-newlines?"] and (#str < (options["line-length"] - indent))) then + _2_ = "\\n" + else + _2_ = "\n" + end + local function _4_(_241, _242) + return ("\\%03d"):format(_242:byte()) + end + escs = setmetatable({["\""] = "\\\"", ["\11"] = "\\v", ["\12"] = "\\f", ["\13"] = "\\r", ["\7"] = "\\a", ["\8"] = "\\b", ["\9"] = "\\t", ["\\"] = "\\\\", ["\n"] = _2_}, {__index = _4_}) + return ("\"" .. str:gsub("[%c\\\"]", escs) .. "\"") end local function make_options(t, options) - local defaults = {["associative-length"] = 4, ["detect-cycles?"] = true, ["empty-as-sequence?"] = false, ["line-length"] = 80, ["metamethod?"] = true, ["one-line?"] = false, ["sequential-length"] = 10, ["utf8?"] = true, depth = 128} + 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 overrides = {appearances = count_table_appearances(t, {}), level = 0, seen = {len = 0}} for k, v in pairs((options or {})) do defaults[k] = v @@ -797,34 +788,46 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) end return defaults end - pp.pp = function(x, options, indent, key_3f) + local function _2_(x, options, indent, colon_3f) local indent0 = (indent or 0) local options0 = (options or make_options(x)) local tv = type(x) - local function _3_() - local _2_0 = getmetatable(x) - if _2_0 then - return _2_0.__fennelview + local function _4_() + local _3_0 = getmetatable(x) + if _3_0 then + return _3_0.__fennelview else - return _2_0 + return _3_0 end end - if ((tv == "table") or ((tv == "userdata") and _3_())) then + if ((tv == "table") or ((tv == "userdata") and _4_())) then return pp_table(x, options0, indent0) elseif (tv == "number") then return number__3estring(x) - elseif ((tv == "string") and key_3f and colon_string_3f(x)) then - return (":" .. x) - elseif (tv == "string") then - return string.format("%q", x) - elseif ((tv == "boolean") or (tv == "nil")) then - return tostring(x) else - return ("#<" .. tostring(x) .. ">") + local function _5_() + if (colon_3f ~= nil) then + return colon_3f + elseif ("function" == type(options0["prefer-colon?"])) then + return options0["prefer-colon?"](x) + else + return options0["prefer-colon?"] + end + end + if ((tv == "string") and colon_string_3f(x) and _5_()) then + return (":" .. x) + elseif (tv == "string") then + return pp_string(x, options0, indent0) + elseif ((tv == "boolean") or (tv == "nil")) then + return tostring(x) + else + return ("#<" .. tostring(x) .. ">") + end end end + pp = _2_ local function view(x, options) - return pp.pp(x, make_options(x, options), 0) + return pp(x, make_options(x, options), 0) end return view end @@ -1011,8 +1014,8 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct 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, ", ") .. "}")} @@ -1034,9 +1037,30 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct 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 @@ -1047,7 +1071,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct 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) @@ -1066,30 +1090,18 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct 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.") SPECIALS.lua = function(ast, _, parent) @@ -1109,8 +1121,9 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct 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.") @@ -1262,7 +1275,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct 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) @@ -1314,9 +1327,23 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct 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 until_condition = remove_until_condition(binding) local iter = table.remove(binding, #binding) local destructures = {} local new_manglings = {} @@ -1339,6 +1366,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct 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) @@ -1367,6 +1395,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct doc_special("while", {"condition", "..."}, "The classic while loop. Evaluates body until a condition is non-truthy.") 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 = {} @@ -1377,6 +1406,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct 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) @@ -1502,40 +1532,41 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct 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, ast, scope, parent) + local len = #ast + if (len == 1) then + compiler.assert(zero_arity, "Expected more than 0 arguments", ast) + return utils.expr(zero_arity, "literal") + else + local operands = {} + local padded_op = (" " .. name .. " ") + for i = 2, len do + local subexprs = nil + local _0_ + if (i ~= len) then + _0_ = 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 + _0_ = nil end + subexprs = compiler.compile1(ast[i], scope, parent, {nval = _0_}) + 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 - 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, ...) + 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") @@ -1546,16 +1577,57 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct 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+.") + 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.") define_arithmetic_special("or", "false") define_arithmetic_special("and", "true") doc_special("and", {"a", "b", "..."}, "Boolean operator; works the same as Lua but accepts more arguments.") @@ -1607,7 +1679,6 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct 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) @@ -1620,9 +1691,10 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct 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") @@ -1637,7 +1709,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct 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 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 @@ -1646,8 +1718,22 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end return v end - local safe_compiler_env = setmetatable({assert = assert, bit = rawget(_G, "bit"), error = error, getmetatable = getmetatable, ipairs = ipairs, math = math, next = next, pairs = pairs, pcall = pcall, print = print, rawequal = rawequal, rawget = rawget, rawlen = rawget(_G, "rawlen"), rawset = rawset, select = select, setmetatable = setmetatable, string = string, table = table, tonumber = tonumber, tostring = tostring, type = type, xpcall = xpcall}, {__index = compiler_env_warn}) - local function make_compiler_env(ast, scope, parent) + local function safe_getmetatable(tbl) + local mt = getmetatable(tbl) + assert((mt ~= getmetatable("")), "Illegal metatable access!") + return mt + end + local safe_require = nil + local function safe_compiler_env(strict_3f) + local _1_ + if strict_3f then + _1_ = nil + else + _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 make_compiler_env(ast, scope, parent, strict_3f) local function _1_() return compiler.scopes.macro end @@ -1665,7 +1751,9 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local _6_ do local _5_0 = utils.root.options - if ((type(_5_0) == "table") and (nil ~= _5_0.compilerEnv)) then + 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 @@ -1673,7 +1761,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct _6_ = compiler_env else local _ = _5_0 - _6_ = safe_compiler_env + _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_}) @@ -1733,10 +1821,31 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end return allowed end - local function compiler_env_domodule(modname, env, _3fast) - local filename = compiler.assert(search_module(modname), (modname .. " module not found."), _3fast) - local globals = macro_globals(env, current_global_names()) - return utils["fennel-module"].dofile(filename, {allowedGlobals = globals, env = env, scope = compiler.scopes.compiler, useMetadata = utils.root.options.useMetadata}, modname, filename) + local function default_macro_searcher(module_name) + local _1_0 = search_module(module_name) + 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 macro_searchers = {default_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) @@ -1744,14 +1853,16 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return {metadata = compiler.metadata} end end - safe_compiler_env.require = function(modname) - local function _1_() - local mod = compiler_env_domodule(modname, safe_compiler_env) - macro_loaded[modname] = mod - return mod + local function _1_(modname) + local function _2_() + 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 _1_()) + return (macro_loaded[modname] or metadata_only_fennel(modname) or _2_()) end + safe_require = _1_ local function add_macros(macros_2a, ast, scope) compiler.assert(utils["table?"](macros_2a), "expected macros to be table", ast) for k, v in pairs(macros_2a) do @@ -1763,12 +1874,14 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct 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 @@ -1807,10 +1920,10 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return error(..., 0) end end - local function _1_() + local function _2_() return f:read("*all"):gsub("[\13\n]*$", "") end - src = close_handlers_0_(xpcall(_1_, (package.loaded.fennel or debug).traceback)) + src = close_handlers_0_(xpcall(_2_, (package.loaded.fennel or debug).traceback)) end local ret = utils.expr(("require(\"" .. mod .. "\")"), "statement") local target = ("package.preload[%q]"):format(mod) @@ -1847,13 +1960,13 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end else local mod = load_code(("return " .. modexpr[1]))() - local function _2_() - local _1_0 = search_module(mod) - if (nil ~= _1_0) then - local fennel_path = _1_0 + local function _3_() + local _2_0 = search_module(mod) + if (nil ~= _2_0) then + local fennel_path = _2_0 return include_path(ast, opts, fennel_path, mod, true) else - local _ = _1_0 + local _ = _2_0 local lua_path = search_module(mod, package.path) if lua_path then return include_path(ast, opts, lua_path, mod, false) @@ -1864,7 +1977,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end end end - return (include_circular_fallback(mod, modexpr, opts.fallback, ast) or utils.root.scope.includes[mod] or _2_()) + return (include_circular_fallback(mod, modexpr, opts.fallback, ast) or utils.root.scope.includes[mod] or _3_()) end end doc_special("include", {"module-name-literal"}, "Like require but load the target module during compilation and embed it in the\nLua output. The module must be a string literal and resolvable at compile time.") @@ -1888,7 +2001,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct 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} + 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") @@ -2061,7 +2174,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local name = utils.deref(symbol) if (io and io.stderr and name:find("&") and not already_warned[symbol]) then already_warned[symbol] = true - do end (io.stderr):write(("-- Warning: & will not be allowed in identifier names in " .. "future versions: " .. symbol.filename .. ":" .. symbol.line .. "\n")) + do end (io.stderr):write(("-- Warning: & will not be allowed in identifier names in " .. "future versions: " .. (symbol.filename or "unknown") .. ":" .. (symbol.line or "?") .. "\n")) end assert_compile(not (scope.specials[name] or scope.macros[name]), ("local %s was overshadowed by a special form or macro"):format(name), ast) return assert_compile(not utils["quoted?"](symbol), string.format("macro tried to bind %s without gensym", name), symbol) @@ -2096,7 +2209,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct 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: " .. parts[1]), symbol) + assert_compile((not reference_3f or local_3f or global_allowed(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 @@ -2126,6 +2239,10 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct return utils.map(chunk, peephole) end end + local function ast_source(ast) + 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, out, last_line, file) local last_line0 = last_line @@ -2134,8 +2251,9 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct else for _, subchunk in ipairs(chunk) do if (subchunk.leaf or (#subchunk > 0)) then - if (subchunk.ast and (file == subchunk.ast.file)) then - last_line0 = math.max(last_line0, (subchunk.ast.line or 0)) + local source = ast_source(subchunk.ast) + if (file == source.file) then + last_line0 = math.max(last_line0, (source.line or 0)) end last_line0 = flatten(subchunk, out, last_line0, file) end @@ -2157,7 +2275,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local code = chunk.leaf local info = chunk.ast if sm then - table.insert(sm, ((info and info.line) or ( - 1))) + table.insert(sm, {(info and info.filename), (info and info.line)}) end return code else @@ -2206,7 +2324,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local sm = {} local ret = flatten_chunk(sm, chunk0, options.indent, 0) if sm then - sm.short_src = make_short_src((options.filename or options.source or ret)) + sm.short_src = (options.filename or make_short_src((options.source or ret))) if options.filename then sm.key = ("@" .. options.filename) else @@ -2246,14 +2364,19 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct return table.concat(utils.map(exprs, 1), ", ") end local function keep_side_effects(exprs, chunk, start, ast) - local start0 = (start or 1) - for j = start0, #exprs do + for j = (start or 1), #exprs do local se = exprs[j] if ((se.type == "expression") and (se[1] ~= "nil")) then emit(chunk, string.format("do local _ = %s end", tostring(se)), ast) elseif (se.type == "statement") then local code = tostring(se) - emit(chunk, (((code:byte() == 40) and ("do end " .. code)) or code), ast) + local unambiguous_code = nil + if (code:byte() == 40) then + unambiguous_code = ("; " .. code) + else + unambiguous_code = code + end + emit(chunk, unambiguous_code, ast) end end return nil @@ -2315,26 +2438,35 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct 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 - 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 + _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 + return macroexpand_2a(transformed, scope) + end + else + local _ = _0_0 + return ast end end local function compile_special(ast, scope, parent, opts, special) @@ -2396,7 +2528,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct elseif (multi_sym_parts and multi_sym_parts["multi-sym-method-call"]) then local table_with_method = table.concat({unpack(multi_sym_parts, 1, (#multi_sym_parts - 1))}, ".") local method_to_call = multi_sym_parts[#multi_sym_parts] - local new_ast = utils.list(utils.sym(":", scope), utils.sym(table_with_method, scope), method_to_call, 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) @@ -2418,25 +2550,8 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct return handle_compile_opts({e}, parent, opts, ast) end local function serialize_number(n) - local _0_0, _1_0, _2_0 = math.modf(n) - if ((nil ~= _0_0) and (_1_0 == 0)) then - local int = _0_0 - return tostring(int) - else - local _3_ - do - local frac = _1_0 - _3_ = (((_0_0 == 0) and (nil ~= _1_0)) and (frac < 0)) - end - if _3_ then - local frac = _1_0 - return ("-0." .. tostring(frac):gsub("^-?0.", "")) - elseif ((nil ~= _0_0) and (nil ~= _1_0)) then - local int = _0_0 - local frac = _1_0 - return (int .. "." .. tostring(frac):gsub("^-?0.", "")) - end - end + local _0_0 = string.gsub(tostring(n), ",", ".") + return _0_0 end local function compile_scalar(ast, _scope, parent, opts) local serialize = nil @@ -2484,9 +2599,13 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct 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 @@ -2516,8 +2635,6 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct 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 @@ -2529,7 +2646,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct 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 @@ -2538,7 +2655,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct 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) @@ -2573,6 +2690,8 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct 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 @@ -2747,8 +2866,12 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct else local remap = fennel_sourcemap[info.source] if (remap and remap[info.currentline]) then - info["short-src"] = remap["short-src"] - info.currentline = remap[info.currentline] + if remap[info.currentline][1] then + info.short_src = fennel_sourcemap[("@" .. remap[info.currentline][1])].short_src + else + info.short_src = remap.short_src + end + info.currentline = (remap[info.currentline][2] or -1) end if (info.what == "Lua") then local function _1_() @@ -2759,7 +2882,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end end return string.format(" %s:%d: in function %s", info.short_src, info.currentline, _1_()) - elseif (info["short-src"] == "(tail call)") then + elseif (info.short_src == "(tail call)") then return " (tail call)" else return string.format(" %s:%d: in main chunk", info.short_src, info.currentline) @@ -2805,9 +2928,6 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end return _0_ end - local function no() - return nil - end local function mixed_concat(t, joiner) local seen = {} local ret, s = "", "" @@ -2841,16 +2961,20 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct 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) @@ -2859,6 +2983,22 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end assert_compile(not runtime_3f, "lists may only be used at compile time", form) return string.format(("setmetatable({filename=%s, line=%s, bytestart=%s, %s}" .. ", getmetatable(list()))"), filename, (form.line or "nil"), (form.bytestart or "nil"), mixed_concat(mapped, ", ")) + elseif utils["sequence?"](form) then + local mapped = utils.kvmap(form, entry_transform(q, q)) + local source = getmetatable(form) + local filename = nil + if source.filename then + filename = string.format("%q", source.filename) + else + filename = "nil" + end + local _1_ + if source then + _1_ = source.line + else + _1_ = "nil" + end + return string.format("setmetatable({%s}, {filename=%s, line=%s, sequence=%s})", mixed_concat(mapped, ", "), filename, _1_, "(getmetatable(sequence()))['sequence']") elseif (type(form) == "table") then local mapped = utils.kvmap(form, entry_transform(q, q)) local source = getmetatable(form) @@ -2889,7 +3029,7 @@ package.preload["fennel.friend"] = package.preload["fennel.friend"] 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 not to return a coroutine or userdata"}, ["could not read number (.*)"] = {"removing the non-digit character", "beginning the identifier with a non-digit if it is not meant to be a number"}, ["expected a function.* to call"] = {"removing the empty parentheses", "using square brackets if you want an empty table"}, ["expected binding table"] = {"placing a table here in square brackets containing identifiers to bind"}, ["expected body expression"] = {"putting some code in the body of this form after the bindings"}, ["expected each macro to be function"] = {"ensuring that the value for each key in your macros table contains a function", "avoid defining nested macro tables"}, ["expected even number of name/value bindings"] = {"finding where the identifier or value is missing"}, ["expected even number of values in table literal"] = {"removing a key", "adding a value"}, ["expected local"] = {"looking for a typo", "looking for a local which is used out of its scope"}, ["expected macros to be table"] = {"ensuring your macro definitions return a table"}, ["expected parameters"] = {"adding function parameters as a list of identifiers in brackets"}, ["expected rest argument before last parameter"] = {"moving & to right before the final identifier when destructuring"}, ["expected symbol for function parameter: (.*)"] = {"changing %s to an identifier instead of a literal value"}, ["expected var (.*)"] = {"declaring %s using var instead of let/local", "introducing a new local instead of changing the value of %s"}, ["expected vararg as last parameter"] = {"moving the \"...\" to the end of the parameter list"}, ["expected whitespace before opening delimiter"] = {"adding whitespace"}, ["global (.*) conflicts with local"] = {"renaming local %s"}, ["illegal character: (.)"] = {"deleting or replacing %s", "avoiding reserved characters like \", \\, ', ~, ;, @, `, and comma"}, ["local (.*) was overshadowed by a special form or macro"] = {"renaming local %s"}, ["macro not found in macro module"] = {"checking the keys of the imported macro module's returned table"}, ["macro tried to bind (.*) without gensym"] = {"changing to %s# when introducing identifiers inside macros"}, ["malformed multisym"] = {"ensuring each period or colon is not followed by another period or colon"}, ["may only be used at compile time"] = {"moving this to inside a macro if you need to manipulate symbols/lists", "using square brackets instead of parens to construct a table"}, ["method must be last component"] = {"using a period instead of a colon for field access", "removing segments after the colon", "making the method call, then looking up the field on the result"}, ["mismatched closing delimiter (.), expected (.)"] = {"replacing %s with %s", "deleting %s", "adding matching opening delimiter earlier"}, ["multisym method calls may only be in call position"] = {"using a period instead of a colon to reference a table's fields", "putting parens around this"}, ["unable to bind (.*)"] = {"replacing the %s with an identifier"}, ["unexpected closing delimiter (.)"] = {"deleting %s", "adding matching opening delimiter earlier"}, ["unexpected multi symbol (.*)"] = {"removing periods or colons from %s"}, ["unexpected vararg"] = {"putting \"...\" at the end of the fn parameters if the vararg was intended"}, ["unknown global in strict mode: (.*)"] = {"looking to see if there's a typo", "using the _G table instead, eg. _G.%s if you really want a global", "moving this code to somewhere that %s is in scope", "binding %s as a local in the scope of this code"}, ["unused local (.*)"] = {"fixing a typo so %s is used", "renaming the local to _%s"}, ["use of global (.*) is aliased by a local"] = {"renaming local %s", "refer to the global using _G.%s instead of directly"}} + local 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 unpack = (table.unpack or _G.unpack) local function suggest(msg) local suggestion = nil @@ -2921,21 +3061,19 @@ package.preload["fennel.friend"] = package.preload["fennel.friend"] or function( f:close() return codeline, bytes end - local function read_line_from_source(source, line) - local lines, bytes, codeline = 0, 0 - for this_line, newline in string.gmatch((source .. "\n"), "(.-)(\13?\n)") do - lines = (lines + 1) - if (lines == line) then - codeline = this_line - break - end - bytes = (bytes + #newline + #this_line) + local function read_line_from_string(matcher, target_line, _3fcurrent_line, _3fbytes) + local this_line, newline = matcher() + local current_line = (_3fcurrent_line or 1) + local bytes = ((_3fbytes or 0) + #this_line + #newline) + if (target_line == current_line) then + return this_line, bytes + elseif this_line then + return read_line_from_string(matcher, target_line, (current_line + 1), bytes) end - return codeline, bytes end local function read_line(filename, line, source) if source then - return read_line_from_source(source, line) + return read_line_from_string(string.gmatch((source .. "\n"), "(.-)(\13?\n)"), line) else return read_line_from_file(filename, line) end @@ -3068,6 +3206,7 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( end return r end + assert(((nil == filename) or ("string" == type(filename))), "expected filename as second argument to parser") local function parse_error(msg, byteindex_override) local _0_ = (options or utils.root.options or {}) local source = _0_["source"] @@ -3088,8 +3227,17 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( return nil elseif ((type(_0_0) == "table") and (nil ~= _0_0.prefix)) then local prefix = _0_0.prefix - table.remove(stack) - return dispatch(utils.list(utils.sym(prefix), v)) + local source = nil + do + local _1_0 = table.remove(stack) + _1_0["byteend"] = byteindex + source = _1_0 + end + local list = utils.list(utils.sym(prefix, source), v) + for k, v0 in pairs(source) do + list[k] = v0 + end + return dispatch(list) elseif (nil ~= _0_0) then local top = _0_0 whitespace_since_dispatch = false @@ -3125,7 +3273,7 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( end return parse_comment(getb(), _1_()) elseif (options and options.comments) then - return dispatch(utils.comment(table.concat(contents))) + return dispatch(utils.comment(table.concat(contents), {filename = filename, line = (line - 1)})) else return b end @@ -3146,7 +3294,49 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( end return dispatch(val) end + 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 + 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 + 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 + add_comment_at(comments.values, next_noncomment(tbl, i), node) + else + add_comment_at(comments.keys, next_noncomment(tbl, i), node) + end + end + for i = #tbl, 1, -1 do + if utils["comment?"](tbl[i]) then + table.remove(tbl, i) + end + end + return comments + end local function close_curly_table(tbl) + local comments = extract_comments(tbl) + local keys = {} local val = {} if ((#tbl % 2) ~= 0) then byteindex = (byteindex - 1) @@ -3158,7 +3348,10 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( tbl[i] = tostring(tbl[(i + 1)]) end val[tbl[i]] = tbl[(i + 1)] + table.insert(keys, tbl[i]) end + tbl.comments = comments + tbl.keys = keys return dispatch(val) end local function close_table(b) @@ -3166,7 +3359,7 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( if (top == nil) then parse_error(("unexpected closing delimiter " .. string.char(b))) end - if (top.closer ~= b) then + if (top.closer and (top.closer ~= b)) then parse_error(("mismatched closing delimiter " .. string.char(b) .. ", expected " .. string.char(top.closer))) end top.byteend = byteindex @@ -3214,9 +3407,9 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( return dispatch(load_fn()) end local function parse_prefix(b) - table.insert(stack, {prefix = prefixes[b]}) + table.insert(stack, {bytestart = byteindex, filename = filename, line = line, prefix = prefixes[b]}) local nextb = getb() - if whitespace_3f(nextb) then + if (whitespace_3f(nextb) or (true == delims[nextb])) then if (b ~= 35) then parse_error("invalid whitespace after quoting prefix") end @@ -3257,11 +3450,13 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] 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) @@ -3275,12 +3470,8 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] 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) @@ -3325,19 +3516,27 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] 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 succ[k] = keys[(i + 1)] end local function stablenext(tbl, idx) + local key = nil if (idx == nil) then - return keys[1], tbl[keys[1]] + key = keys[1] else - return succ[idx], tbl[succ[idx]] + key = succ[idx] end + local value = nil + if (key == nil) then + value = nil + else + value = tbl[key] + end + return key, value end return stablenext, t, nil end @@ -3347,9 +3546,8 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] 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 @@ -3368,9 +3566,8 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] 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 @@ -3442,10 +3639,19 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. end return ("(" .. table.concat(map(safe, (tostring2 or tostring)), " ", 1, max) .. ")") end - local symbol_mt = {"SYMBOL", __fennelview = deref, __tostring = deref} + local function comment_view(c) + return c, true + end + local function sym_3d(a, b) + return ((deref(a) == deref(b)) and (getmetatable(a) == getmetatable(b))) + end + local function sym_3c(a, b) + return (a[1] < tostring(b)) + end + local symbol_mt = {"SYMBOL", __eq = sym_3d, __fennelview = deref, __lt = sym_3c, __tostring = deref} local expr_mt = {"EXPR", __tostring = deref} local list_mt = {"LIST", __fennelview = list__3estring, __tostring = list__3estring} - local comment_mt = {"COMMENT", __fennelview = deref, __tostring = deref} + local comment_mt = {"COMMENT", __eq = sym_3d, __fennelview = comment_view, __lt = sym_3c, __tostring = deref} local sequence_marker = {"SEQUENCE"} local vararg = setmetatable({"..."}, {"VARARG", __fennelview = deref, __tostring = deref}) local getenv = nil @@ -3460,9 +3666,9 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] 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 @@ -3476,8 +3682,11 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. local function expr(strcode, etype) return setmetatable({strcode, type = etype}, expr_mt) end - local function comment_2a(contents) - return setmetatable({contents}, comment_mt) + 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) end local function varg() return vararg @@ -3494,9 +3703,6 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] 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) @@ -3504,6 +3710,9 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] 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)) @@ -3591,7 +3800,7 @@ 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 get_env(env) + local function eval_env(env) if (env == "_COMPILER") then local env0 = specials["make-compiler-env"](nil, compiler.scopes.compiler, {}) local mt = getmetatable(env0) @@ -3601,26 +3810,32 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) return (env and specials["wrap-env"](env)) end end - local function eval(str, options, ...) + local function eval_opts(options, str) local opts = utils.copy(options) - local _ = nil if ((opts.allowedGlobals == nil) and not getmetatable(opts.env)) then opts.allowedGlobals = specials["current-global-names"](opts.env) - _ = nil - else - _ = nil end - local env = get_env(opts.env) + 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 lua_source = compiler["compile-string"](str, opts) local loader = nil - local function _1_(...) + local function _0_(...) if opts.filename then return ("@" .. opts.filename) else return str end end - loader = specials["load-code"](lua_source, env, _1_(...)) + loader = specials["load-code"](lua_source, env, _0_(...)) opts.filename = nil return loader(...) end @@ -3632,7 +3847,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) opts.filename = filename return eval(source, opts, ...) end - local mod = {["compile-stream"] = compiler["compile-stream"], ["compile-string"] = compiler["compile-string"], ["list?"] = utils["list?"], ["load-code"] = specials["load-code"], ["macro-loaded"] = specials["macro-loaded"], ["make-searcher"] = specials["make-searcher"], ["search-module"] = specials["search-module"], ["sequence?"] = utils["sequence?"], ["string-stream"] = parser["string-stream"], ["sym-char?"] = parser["sym-char?"], ["sym?"] = utils["sym?"], compile = compiler.compile, compile1 = compiler.compile1, compileStream = compiler["compile-stream"], compileString = compiler["compile-string"], doc = specials.doc, dofile = dofile_2a, eval = eval, gensym = compiler.gensym, granulate = parser.granulate, list = utils.list, loadCode = specials["load-code"], macroLoaded = specials["macro-loaded"], makeSearcher = specials["make-searcher"], make_searcher = specials["make-searcher"], mangle = compiler["global-mangling"], metadata = compiler.metadata, parser = parser.parser, path = utils.path, repl = repl, scope = compiler["make-scope"], searchModule = specials["search-module"], searcher = specials["make-searcher"](), sequence = utils.sequence, stringStream = parser["string-stream"], sym = utils.sym, traceback = compiler.traceback, unmangle = compiler["global-unmangling"], varg = utils.varg, version = "0.9.0-dev", view = view} + 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-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, traceback = compiler.traceback, unmangle = compiler["global-unmangling"], varg = utils.varg, version = "0.9.0", view = view} utils["fennel-module"] = mod do local builtin_macros = [===[;; This module contains all the built-in Fennel macros. Unlike all the other @@ -3645,7 +3860,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) ;; TODO: some of these macros modify their arguments; we should stop doing that, ;; but in a way that preserves file/line metadata. - (fn -> [val ...] + (fn ->* [val ...] "Thread-first macro. Take the first value and splice it into the second form as its first argument. The value of the second form is spliced into the first arg of the third, etc." @@ -3656,7 +3871,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) (set x elt))) x) - (fn ->> [val ...] + (fn ->>* [val ...] "Thread-last macro. Same as ->, except splices the value into the last position of each form rather than the first." @@ -3667,7 +3882,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) (set x elt))) x) - (fn -?> [val ...] + (fn -?>* [val ...] "Nil-safe thread-first macro. Same as -> except will short-circuit with nil when it encounters a nil value." (if (= 0 (select "#" ...)) @@ -3682,7 +3897,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) (-?> ,el ,(unpack els)) ,tmp))))) - (fn -?>> [val ...] + (fn -?>>* [val ...] "Nil-safe thread-last macro. Same as ->> except will short-circuit with nil when it encounters a nil value." (if (= 0 (select "#" ...)) @@ -3697,7 +3912,14 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) (-?>> ,el ,(unpack els)) ,tmp))))) - (fn doto [val ...] + (fn ?dot [tbl k ...] + "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# ,...))))) + + (fn doto* [val ...] "Evaluates val and splices it into the first argument of subsequent forms." (let [name (gensym) form `(let [,name ,val])] @@ -3707,28 +3929,32 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) (table.insert form name) form)) - (fn when [condition body1 ...] + (fn when* [condition body1 ...] "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 ...] + (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 ...] + (fn collect* [iter-tbl key-value-expr ...] "Returns a table made by running an iterator and evaluating an expression that returns key-value pairs to be inserted sequentially into the table. This can be thought of as a \"table comprehension\". The provided key-value @@ -3741,8 +3967,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# {}] @@ -3751,7 +3976,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) (k# v#) (tset tbl# k# v#))) tbl#)) - (fn icollect [iter-tbl value-expr ...] + (fn icollect* [iter-tbl value-expr ...] "Returns a sequential table made by running an iterator and evaluating an expression that returns values to be inserted sequentially into the table. This can be thought of as a \"list comprehension\". @@ -3762,8 +3987,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# []] @@ -3771,13 +3995,15 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) (tset tbl# (+ (length tbl#) 1) ,value-expr)) tbl#)) - (fn partial [f ...] + (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))) + `(fn [,_VARARG] + ,body))) - (fn pick-args [n f] + (fn pick-args* [n f] "Creates a function of arity n that applies its arguments to f. For example, @@ -3785,12 +4011,14 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) expands to (fn [_0_ _1_] (func _0_ _1_))" (assert (and (= (type n) :number) (= n (math.floor n)) (>= n 0)) - "Expected n to be an integer literal >= 0.") + (.. "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 ...] + (fn pick-values* [n ...] "Like the `values` special, but emits exactly n values. For example, @@ -3799,14 +4027,16 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) (let [(_0_ _1_) ...] (values _0_ _1_))" (assert (and (= :number (type n)) (>= n 0) (= n (math.floor n))) - "Expected n to be an integer >= 0") - (let [let-syms (list) - let-values (if (= 1 (select :# ...)) ... `(values ,...))] - (for [i 1 n] (table.insert let-syms (gensym))) + (.. "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))) (if (= n 0) `(values) - `(let [,let-syms ,let-values] (values ,(unpack let-syms)))))) + `(let [,let-syms ,let-values] + (values ,(unpack let-syms)))))) - (fn lambda [...] + (fn lambda* [...] "Function literal with arity checking. Will throw an exception if a declared argument is passed in as nil, unless that argument name begins with ?." @@ -3814,23 +4044,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)) @@ -3838,27 +4070,27 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) (table.insert args (sym :nil))) `(fn ,(unpack args)))) - (fn macro [name ...] + (fn macro* [name ...] "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?] + (fn macrodebug* [form return?] "Print the resulting form after performing macroexpansion. With a second argument, returns expanded form as a string instead of printing." (let [handle (if return? `do `print)] `(,handle ,(view (macroexpand form _SCOPE))))) - (fn import-macros [binding1 module-name1 ...] + (fn import-macros* [binding1 module-name1 ...] "Binds a table of macros from each macro module according to a binding form. Each binding form can be either a symbol or a k/v destructuring table. 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 @@ -3868,10 +4100,10 @@ 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))) - + (do + (tset scope.macros (. binding 1) {}) + (each [k v (pairs subscope.macros)] + (tset (. scope.macros (. binding 1)) k v))) ;; 1-level table destructuring for importing individual macros (table? binding) (each [macro-name [import-key] (pairs binding)] @@ -3898,16 +4130,26 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) (let [condition `(and (= (type ,val) :table)) bindings []] (each [k pat (pairs pattern)] - (if (and (sym? pat) (= "&" (tostring pat))) - (do (assert (not (. pattern (+ k 2))) - "expected rest argument before last parameter") - (table.insert bindings (. pattern (+ k 1))) - (table.insert bindings [`(select ,k ((or table.unpack - _G.unpack) - ,val))])) - (and (= :number (type k)) - (= "&" (tostring (. pattern (- k 1))))) - nil ; don't process the pattern right after &; already got it + (if (= pat `&) + (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)] @@ -3925,11 +4167,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))) @@ -3938,18 +4178,17 @@ 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) (sym? (. pattern 2)) (= :? (tostring (. pattern 2)))) + (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 + (for [i 3 (length pattern)] ; splice in guard clauses (table.insert condition (. pattern i))) - (values `(let ,bindings ,condition) bindings)) - + (values `(let ,bindings + ,condition) bindings)) ;; multi-valued patterns (represented as lists) (list? pattern) (match-values vals pattern unifications match-pattern) @@ -3962,14 +4201,15 @@ 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] @@ -3982,22 +4222,101 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) (tset syms valnum (gensym)))))) syms)) - (fn match [val ...] - "Perform pattern matching on val. See reference for details." + (fn match* [val ...] + ;; Old implementation of match macro, which doesn't directly support + ;; `where' and `or'. New syntax is implemented in `match-where', + ;; which simply generates old syntax and feeds it to `match*'. (let [clauses [...] 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)))) - {: -> : ->> : -?> : -?>> - : doto : when : with-open - : collect : icollect - : partial : lambda - : pick-args : pick-values - : macro : macrodebug : import-macros - : match} + ;; Construction of old match syntax from new syntax + + (fn partition-2 [seq] + ;; Partition `seq` by 2. + ;; If `seq` has odd amount of elements, the last one is dropped. + ;; + ;; Input: [1 2 3 4 5] + ;; Output: [[1 2] [3 4]] + (let [firsts [] + seconds [] + res []] + (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)))) + (each [i v1 (ipairs firsts)] + (let [v2 (. seconds i)] + (if (not= nil v2) + (table.insert res [v1 v2])))) + res)) + + (fn transform-or [[_ & pats] guards] + ;; Transforms `(or pat pats*)` lists into match `guard` patterns. + ;; + ;; (or pat1 pat2), guard => [(pat1 ? guard) (pat2 ? guard)] + (let [res []] + (each [_ pat (ipairs pats)] + (table.insert res (list pat `? (unpack guards)))) + res)) + + (fn transform-cond [cond] + ;; Transforms `where` cond into sequence of `match` guards. + ;; + ;; pat => [pat] + ;; (where pat guard) => [(pat ? guard)] + ;; (where (or pat1 pat2) guard) => [(pat1 ? guard) (pat2 ? guard)] + (if (and (list? cond) (= (. cond 1) `where)) + (let [second (. cond 2)] + (if (and (list? second) (= (. second 1) `or)) + (transform-or second [(unpack cond 3)]) + :else + [(list second `? (unpack cond 3))])) + :else + [cond])) + + (fn match-where [val ...] + "Perform pattern matching on val. See reference for details. + + Syntax: + + (match data-expression + pattern body + (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 "#" ...) ...)) + match-body []] + (each [_ [cond body] (ipairs conds-bodies)] + (each [_ cond (ipairs (transform-cond cond))] + (table.insert match-body cond) + (table.insert match-body body))) + (if else-branch + (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* + :match match-where} ]===] local module_name = "fennel.macros" local _ = nil @@ -4024,7 +4343,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) end fennel = require("fennel") local unpack = (table.unpack or _G.unpack) -local help = "\nUsage: fennel [FLAG] [FILE]\n\nRun fennel, a lisp programming language for the Lua runtime.\n\n --repl : Command to launch an interactive repl session\n --compile FILES : Command to AOT compile files, writing Lua to stdout\n --eval SOURCE (-e) : Command to evaluate source code and print the result\n\n --no-searcher : Skip installing package.searchers entry\n --indent VAL : Indent compiler output with VAL\n --add-package-path PATH : Add PATH to package.path for finding Lua modules\n --add-fennel-path PATH : Add PATH to fennel.path for finding Fennel modules\n --globals G1[,G2...] : Allow these globals in addition to standard ones\n --globals-only G1[,G2] : Same as above, but exclude standard ones\n --require-as-include : Inline required modules in the output\n --metadata : Enable function metadata, even in compiled output\n --no-metadata : Disable function metadata, even in REPL\n --correlate : Make Lua output line numbers match Fennel input\n --load FILE (-l) : Load the specified FILE before executing the command\n --lua LUA_EXE : Run in a child process with LUA_EXE\n --no-fennelrc : Skip loading ~/.fennelrc when launching repl\n --plugin FILE : Activate the compiler plugin in FILE\n --compile-binary FILE\n OUT LUA_LIB LUA_DIR : Compile FILE to standalone binary OUT\n --compile-binary --help : Display further help for compiling binaries\n --no-compiler-sandbox : Do not limit compiler environment to minimal sandbox\n\n --help (-h) : Display this text\n --version (-v) : Show version\n\n Globals are not checked when doing AOT (ahead-of-time) compilation unless\n the --globals-only flag is provided.\n\n Metadata is typically considered a development feature and is not recommended\n for production. It is used for docstrings and enabled by default in the REPL.\n\n When not given a command, runs the file given as the first argument.\n When given neither command nor file, launches a repl.\n\n If ~/.fennelrc exists, loads it before launching a repl." +local help = "\nUsage: fennel [FLAG] [FILE]\n\nRun fennel, a lisp programming language for the Lua runtime.\n\n --repl : Command to launch an interactive repl session\n --compile FILES : Command to AOT compile files, writing Lua to stdout\n --eval SOURCE (-e) : Command to evaluate source code and print the result\n\n --no-searcher : Skip installing package.searchers entry\n --indent VAL : Indent compiler output with VAL\n --add-package-path PATH : Add PATH to package.path for finding Lua modules\n --add-fennel-path PATH : Add PATH to fennel.path for finding Fennel modules\n --globals G1[,G2...] : Allow these globals in addition to standard ones\n --globals-only G1[,G2] : Same as above, but exclude standard ones\n --require-as-include : Inline required modules in the output\n --use-bit-lib : Use LuaJITs bit library instead of operators\n --metadata : Enable function metadata, even in compiled output\n --no-metadata : Disable function metadata, even in REPL\n --correlate : Make Lua output line numbers match Fennel input\n --load FILE (-l) : Load the specified FILE before executing the command\n --lua LUA_EXE : Run in a child process with LUA_EXE\n --no-fennelrc : Skip loading ~/.fennelrc when launching repl\n --plugin FILE : Activate the compiler plugin in FILE\n --compile-binary FILE\n OUT LUA_LIB LUA_DIR : Compile FILE to standalone binary OUT\n --compile-binary --help : Display further help for compiling binaries\n --no-compiler-sandbox : Do not limit compiler environment to minimal sandbox\n\n --help (-h) : Display this text\n --version (-v) : Show version\n\n Globals are not checked when doing AOT (ahead-of-time) compilation unless\n the --globals-only flag is provided.\n\n Metadata is typically considered a development feature and is not recommended\n for production. It is used for docstrings and enabled by default in the REPL.\n\n When not given a command, runs the file given as the first argument.\n When given neither command nor file, launches a repl.\n\n If ~/.fennelrc exists, loads it before launching a repl." local options = {plugins = {}} local function dosafely(f, ...) local args = {...} @@ -4117,6 +4436,9 @@ for i = #arg, 1, -1 do elseif (_0_0 == "--require-as-include") then options.requireAsInclude = true table.remove(arg, i) + elseif (_0_0 == "--use-bit-lib") then + options.useBitLib = true + table.remove(arg, i) elseif (_0_0 == "--metadata") then options.useMetadata = true table.remove(arg, i) diff --git a/lib/fennel.lua b/lib/fennel.lua index b67b281..533f181 100644 --- a/lib/fennel.lua +++ b/lib/fennel.lua @@ -333,12 +333,14 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) end local function table_kv_pairs(t) local assoc_3f = false + local i = 1 local kv = {} local insert = table.insert for k, v in pairs(t) do - if (type(k) ~= "number") then + if ((type(k) ~= "number") or (k ~= i)) then assoc_3f = true end + i = (i + 1) insert(kv, {k, v}) end table.sort(kv, sort_keys) @@ -378,21 +380,19 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) end return seen0 end - local function detect_cycle(t, seen) - local seen0 = (seen or {}) - seen0[t] = true - for k, v in pairs(t) do - if ((type(k) == "table") and (seen0[k] or detect_cycle(k, seen0))) then - return true - end - if ((type(v) == "table") and (seen0[v] or detect_cycle(v, seen0))) then - return true + local function detect_cycle(t, seen, _3fk) + if ("table" == type(t)) then + seen[t] = true + local _2_0, _3_0 = next(t, _3fk) + if ((nil ~= _2_0) and (nil ~= _3_0)) then + local k = _2_0 + local v = _3_0 + return (seen[k] or detect_cycle(k, seen) or seen[v] or detect_cycle(v, seen) or detect_cycle(t, seen, k)) end end - return nil end local function visible_cycle_3f(t, options) - return (options["detect-cycles?"] and detect_cycle(t) and save_table(t, options.seen) and (1 < (options.appearances[t] or 0))) + return (options["detect-cycles?"] and detect_cycle(t, {}) and save_table(t, options.seen) and (1 < (options.appearances[t] or 0))) end local function table_indent(t, indent, id) local opener_length = nil @@ -403,7 +403,7 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) end return (indent + opener_length) end - local pp = {} + local pp = nil local function concat_table_lines(elements, options, multiline_3f, indent, table_type, prefix) local indent_str = ("\n" .. string.rep(" ", indent)) local open = nil @@ -422,13 +422,7 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) close = "}" end local oneline = (open .. table.concat(elements, " ") .. close) - local _4_ - if (table_type == "seq") then - _4_ = options["sequential-length"] - else - _4_ = options["associative-length"] - end - if (not options["one-line?"] and (multiline_3f or (#elements > _4_) or ((indent + #oneline) > options["line-length"]))) then + if (not options["one-line?"] and (multiline_3f or ((indent + #oneline) > options["line-length"]))) then return (open .. table.concat(elements, indent_str) .. close) else return oneline @@ -464,7 +458,7 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) else prefix = "" end - local elements = nil + local items = nil do local tbl_0_ = {} for _, _6_0 in pairs(kv) do @@ -473,16 +467,16 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) local v = _7_[2] local _8_ do - local k0 = pp.pp(k, options, (indent0 + 1), true) - local v0 = pp.pp(v, options, (indent0 + slength(k0) + 1)) + local k0 = pp(k, options, (indent0 + 1), true) + local v0 = pp(v, options, (indent0 + slength(k0) + 1)) multiline_3f = (multiline_3f or k0:find("\n") or v0:find("\n")) _8_ = (k0 .. " " .. v0) 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) @@ -502,7 +496,7 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) else prefix = "" end - local elements = nil + local items = nil do local tbl_0_ = {} for _, _3_0 in pairs(kv) do @@ -511,15 +505,15 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) local v = _4_[2] local _5_ do - local v0 = pp.pp(v, options, indent0) + local v0 = pp(v, options, indent0) multiline_3f = (multiline_3f or v0:find("\n")) _5_ = v0 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) @@ -561,7 +555,7 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) end options["visible-cycle?"] = _2_ _ = nil - local lines, force_multi_line_3f = metamethod(t, pp.pp, options, indent) + local lines, force_multi_line_3f = metamethod(t, pp, options, indent) options["visible-cycle?"] = nil local _3_0 = type(lines) if (_3_0 == "string") then @@ -570,7 +564,7 @@ package.preload["fennel.view"] = package.preload["fennel.view"] 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 @@ -622,31 +616,28 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) return x0 end local function number__3estring(n) - local _2_0, _3_0, _4_0 = math.modf(n) - if ((nil ~= _2_0) and (_3_0 == 0)) then - local int = _2_0 - return tostring(int) - else - local _5_ - do - local frac = _3_0 - _5_ = (((_2_0 == 0) and (nil ~= _3_0)) and (frac < 0)) - end - if _5_ then - local frac = _3_0 - return ("-0." .. tostring(frac):gsub("^-?0.", "")) - elseif ((nil ~= _2_0) and (nil ~= _3_0)) then - local int = _2_0 - local frac = _3_0 - return (int .. "." .. tostring(frac):gsub("^-?0.", "")) - end - end + local _2_0 = string.gsub(tostring(n), ",", ".") + return _2_0 end local function colon_string_3f(s) - return s:find("^[-%w?\\^_!$%&*+./@:|<=>]+$") + return s:find("^[-%w?^_!$%&*+./@|<=>]+$") + end + local function pp_string(str, options, indent) + local escs = nil + local _2_ + if (options["escape-newlines?"] and (#str < (options["line-length"] - indent))) then + _2_ = "\\n" + else + _2_ = "\n" + end + local function _4_(_241, _242) + return ("\\%03d"):format(_242:byte()) + end + escs = setmetatable({["\""] = "\\\"", ["\11"] = "\\v", ["\12"] = "\\f", ["\13"] = "\\r", ["\7"] = "\\a", ["\8"] = "\\b", ["\9"] = "\\t", ["\\"] = "\\\\", ["\n"] = _2_}, {__index = _4_}) + return ("\"" .. str:gsub("[%c\\\"]", escs) .. "\"") end local function make_options(t, options) - local defaults = {["associative-length"] = 4, ["detect-cycles?"] = true, ["empty-as-sequence?"] = false, ["line-length"] = 80, ["metamethod?"] = true, ["one-line?"] = false, ["sequential-length"] = 10, ["utf8?"] = true, depth = 128} + 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 overrides = {appearances = count_table_appearances(t, {}), level = 0, seen = {len = 0}} for k, v in pairs((options or {})) do defaults[k] = v @@ -656,34 +647,46 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) end return defaults end - pp.pp = function(x, options, indent, key_3f) + local function _2_(x, options, indent, colon_3f) local indent0 = (indent or 0) local options0 = (options or make_options(x)) local tv = type(x) - local function _3_() - local _2_0 = getmetatable(x) - if _2_0 then - return _2_0.__fennelview + local function _4_() + local _3_0 = getmetatable(x) + if _3_0 then + return _3_0.__fennelview else - return _2_0 + return _3_0 end end - if ((tv == "table") or ((tv == "userdata") and _3_())) then + if ((tv == "table") or ((tv == "userdata") and _4_())) then return pp_table(x, options0, indent0) elseif (tv == "number") then return number__3estring(x) - elseif ((tv == "string") and key_3f and colon_string_3f(x)) then - return (":" .. x) - elseif (tv == "string") then - return string.format("%q", x) - elseif ((tv == "boolean") or (tv == "nil")) then - return tostring(x) else - return ("#<" .. tostring(x) .. ">") + local function _5_() + if (colon_3f ~= nil) then + return colon_3f + elseif ("function" == type(options0["prefer-colon?"])) then + return options0["prefer-colon?"](x) + else + return options0["prefer-colon?"] + end + end + if ((tv == "string") and colon_string_3f(x) and _5_()) then + return (":" .. x) + elseif (tv == "string") then + return pp_string(x, options0, indent0) + elseif ((tv == "boolean") or (tv == "nil")) then + return tostring(x) + else + return ("#<" .. tostring(x) .. ">") + end end end + pp = _2_ local function view(x, options) - return pp.pp(x, make_options(x, options), 0) + return pp(x, make_options(x, options), 0) end return view end @@ -870,8 +873,8 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct 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, ", ") .. "}")} @@ -893,9 +896,30 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct 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 @@ -906,7 +930,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct 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) @@ -925,30 +949,18 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct 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.") SPECIALS.lua = function(ast, _, parent) @@ -968,8 +980,9 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct 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.") @@ -1121,7 +1134,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct 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) @@ -1173,9 +1186,23 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct 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 until_condition = remove_until_condition(binding) local iter = table.remove(binding, #binding) local destructures = {} local new_manglings = {} @@ -1198,6 +1225,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct 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) @@ -1226,6 +1254,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct doc_special("while", {"condition", "..."}, "The classic while loop. Evaluates body until a condition is non-truthy.") 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 = {} @@ -1236,6 +1265,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct 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) @@ -1361,40 +1391,41 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct 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, ast, scope, parent) + local len = #ast + if (len == 1) then + compiler.assert(zero_arity, "Expected more than 0 arguments", ast) + return utils.expr(zero_arity, "literal") + else + local operands = {} + local padded_op = (" " .. name .. " ") + for i = 2, len do + local subexprs = nil + local _0_ + if (i ~= len) then + _0_ = 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 + _0_ = nil end + subexprs = compiler.compile1(ast[i], scope, parent, {nval = _0_}) + 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 - 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, ...) + 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") @@ -1405,16 +1436,57 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct 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+.") + 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.") define_arithmetic_special("or", "false") define_arithmetic_special("and", "true") doc_special("and", {"a", "b", "..."}, "Boolean operator; works the same as Lua but accepts more arguments.") @@ -1466,7 +1538,6 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct 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) @@ -1479,9 +1550,10 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct 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") @@ -1496,7 +1568,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct 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 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 @@ -1505,8 +1577,22 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end return v end - local safe_compiler_env = setmetatable({assert = assert, bit = rawget(_G, "bit"), error = error, getmetatable = getmetatable, ipairs = ipairs, math = math, next = next, pairs = pairs, pcall = pcall, print = print, rawequal = rawequal, rawget = rawget, rawlen = rawget(_G, "rawlen"), rawset = rawset, select = select, setmetatable = setmetatable, string = string, table = table, tonumber = tonumber, tostring = tostring, type = type, xpcall = xpcall}, {__index = compiler_env_warn}) - local function make_compiler_env(ast, scope, parent) + local function safe_getmetatable(tbl) + local mt = getmetatable(tbl) + assert((mt ~= getmetatable("")), "Illegal metatable access!") + return mt + end + local safe_require = nil + local function safe_compiler_env(strict_3f) + local _1_ + if strict_3f then + _1_ = nil + else + _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 make_compiler_env(ast, scope, parent, strict_3f) local function _1_() return compiler.scopes.macro end @@ -1524,7 +1610,9 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local _6_ do local _5_0 = utils.root.options - if ((type(_5_0) == "table") and (nil ~= _5_0.compilerEnv)) then + 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 @@ -1532,7 +1620,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct _6_ = compiler_env else local _ = _5_0 - _6_ = safe_compiler_env + _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_}) @@ -1592,10 +1680,31 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end return allowed end - local function compiler_env_domodule(modname, env, _3fast) - local filename = compiler.assert(search_module(modname), (modname .. " module not found."), _3fast) - local globals = macro_globals(env, current_global_names()) - return utils["fennel-module"].dofile(filename, {allowedGlobals = globals, env = env, scope = compiler.scopes.compiler, useMetadata = utils.root.options.useMetadata}, modname, filename) + local function default_macro_searcher(module_name) + local _1_0 = search_module(module_name) + 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 macro_searchers = {default_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) @@ -1603,14 +1712,16 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return {metadata = compiler.metadata} end end - safe_compiler_env.require = function(modname) - local function _1_() - local mod = compiler_env_domodule(modname, safe_compiler_env) - macro_loaded[modname] = mod - return mod + local function _1_(modname) + local function _2_() + 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 _1_()) + return (macro_loaded[modname] or metadata_only_fennel(modname) or _2_()) end + safe_require = _1_ local function add_macros(macros_2a, ast, scope) compiler.assert(utils["table?"](macros_2a), "expected macros to be table", ast) for k, v in pairs(macros_2a) do @@ -1622,12 +1733,14 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct 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 @@ -1666,10 +1779,10 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return error(..., 0) end end - local function _1_() + local function _2_() return f:read("*all"):gsub("[\13\n]*$", "") end - src = close_handlers_0_(xpcall(_1_, (package.loaded.fennel or debug).traceback)) + src = close_handlers_0_(xpcall(_2_, (package.loaded.fennel or debug).traceback)) end local ret = utils.expr(("require(\"" .. mod .. "\")"), "statement") local target = ("package.preload[%q]"):format(mod) @@ -1706,13 +1819,13 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end else local mod = load_code(("return " .. modexpr[1]))() - local function _2_() - local _1_0 = search_module(mod) - if (nil ~= _1_0) then - local fennel_path = _1_0 + local function _3_() + local _2_0 = search_module(mod) + if (nil ~= _2_0) then + local fennel_path = _2_0 return include_path(ast, opts, fennel_path, mod, true) else - local _ = _1_0 + local _ = _2_0 local lua_path = search_module(mod, package.path) if lua_path then return include_path(ast, opts, lua_path, mod, false) @@ -1723,7 +1836,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end end end - return (include_circular_fallback(mod, modexpr, opts.fallback, ast) or utils.root.scope.includes[mod] or _2_()) + return (include_circular_fallback(mod, modexpr, opts.fallback, ast) or utils.root.scope.includes[mod] or _3_()) end end doc_special("include", {"module-name-literal"}, "Like require but load the target module during compilation and embed it in the\nLua output. The module must be a string literal and resolvable at compile time.") @@ -1747,7 +1860,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct 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} + 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") @@ -1920,7 +2033,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local name = utils.deref(symbol) if (io and io.stderr and name:find("&") and not already_warned[symbol]) then already_warned[symbol] = true - do end (io.stderr):write(("-- Warning: & will not be allowed in identifier names in " .. "future versions: " .. symbol.filename .. ":" .. symbol.line .. "\n")) + do end (io.stderr):write(("-- Warning: & will not be allowed in identifier names in " .. "future versions: " .. (symbol.filename or "unknown") .. ":" .. (symbol.line or "?") .. "\n")) end assert_compile(not (scope.specials[name] or scope.macros[name]), ("local %s was overshadowed by a special form or macro"):format(name), ast) return assert_compile(not utils["quoted?"](symbol), string.format("macro tried to bind %s without gensym", name), symbol) @@ -1955,7 +2068,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct 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: " .. parts[1]), symbol) + assert_compile((not reference_3f or local_3f or global_allowed(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 @@ -1985,6 +2098,10 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct return utils.map(chunk, peephole) end end + local function ast_source(ast) + 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, out, last_line, file) local last_line0 = last_line @@ -1993,8 +2110,9 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct else for _, subchunk in ipairs(chunk) do if (subchunk.leaf or (#subchunk > 0)) then - if (subchunk.ast and (file == subchunk.ast.file)) then - last_line0 = math.max(last_line0, (subchunk.ast.line or 0)) + local source = ast_source(subchunk.ast) + if (file == source.file) then + last_line0 = math.max(last_line0, (source.line or 0)) end last_line0 = flatten(subchunk, out, last_line0, file) end @@ -2016,7 +2134,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local code = chunk.leaf local info = chunk.ast if sm then - table.insert(sm, ((info and info.line) or ( - 1))) + table.insert(sm, {(info and info.filename), (info and info.line)}) end return code else @@ -2065,7 +2183,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local sm = {} local ret = flatten_chunk(sm, chunk0, options.indent, 0) if sm then - sm.short_src = make_short_src((options.filename or options.source or ret)) + sm.short_src = (options.filename or make_short_src((options.source or ret))) if options.filename then sm.key = ("@" .. options.filename) else @@ -2105,14 +2223,19 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct return table.concat(utils.map(exprs, 1), ", ") end local function keep_side_effects(exprs, chunk, start, ast) - local start0 = (start or 1) - for j = start0, #exprs do + for j = (start or 1), #exprs do local se = exprs[j] if ((se.type == "expression") and (se[1] ~= "nil")) then emit(chunk, string.format("do local _ = %s end", tostring(se)), ast) elseif (se.type == "statement") then local code = tostring(se) - emit(chunk, (((code:byte() == 40) and ("do end " .. code)) or code), ast) + local unambiguous_code = nil + if (code:byte() == 40) then + unambiguous_code = ("; " .. code) + else + unambiguous_code = code + end + emit(chunk, unambiguous_code, ast) end end return nil @@ -2174,26 +2297,35 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct 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 - 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 + _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 + return macroexpand_2a(transformed, scope) + end + else + local _ = _0_0 + return ast end end local function compile_special(ast, scope, parent, opts, special) @@ -2255,7 +2387,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct elseif (multi_sym_parts and multi_sym_parts["multi-sym-method-call"]) then local table_with_method = table.concat({unpack(multi_sym_parts, 1, (#multi_sym_parts - 1))}, ".") local method_to_call = multi_sym_parts[#multi_sym_parts] - local new_ast = utils.list(utils.sym(":", scope), utils.sym(table_with_method, scope), method_to_call, 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) @@ -2277,25 +2409,8 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct return handle_compile_opts({e}, parent, opts, ast) end local function serialize_number(n) - local _0_0, _1_0, _2_0 = math.modf(n) - if ((nil ~= _0_0) and (_1_0 == 0)) then - local int = _0_0 - return tostring(int) - else - local _3_ - do - local frac = _1_0 - _3_ = (((_0_0 == 0) and (nil ~= _1_0)) and (frac < 0)) - end - if _3_ then - local frac = _1_0 - return ("-0." .. tostring(frac):gsub("^-?0.", "")) - elseif ((nil ~= _0_0) and (nil ~= _1_0)) then - local int = _0_0 - local frac = _1_0 - return (int .. "." .. tostring(frac):gsub("^-?0.", "")) - end - end + local _0_0 = string.gsub(tostring(n), ",", ".") + return _0_0 end local function compile_scalar(ast, _scope, parent, opts) local serialize = nil @@ -2343,9 +2458,13 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct 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 @@ -2375,8 +2494,6 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct 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 @@ -2388,7 +2505,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct 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 @@ -2397,7 +2514,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct 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) @@ -2432,6 +2549,8 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct 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 @@ -2606,8 +2725,12 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct else local remap = fennel_sourcemap[info.source] if (remap and remap[info.currentline]) then - info["short-src"] = remap["short-src"] - info.currentline = remap[info.currentline] + if remap[info.currentline][1] then + info.short_src = fennel_sourcemap[("@" .. remap[info.currentline][1])].short_src + else + info.short_src = remap.short_src + end + info.currentline = (remap[info.currentline][2] or -1) end if (info.what == "Lua") then local function _1_() @@ -2618,7 +2741,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end end return string.format(" %s:%d: in function %s", info.short_src, info.currentline, _1_()) - elseif (info["short-src"] == "(tail call)") then + elseif (info.short_src == "(tail call)") then return " (tail call)" else return string.format(" %s:%d: in main chunk", info.short_src, info.currentline) @@ -2664,9 +2787,6 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end return _0_ end - local function no() - return nil - end local function mixed_concat(t, joiner) local seen = {} local ret, s = "", "" @@ -2700,16 +2820,20 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct 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) @@ -2718,6 +2842,22 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end assert_compile(not runtime_3f, "lists may only be used at compile time", form) return string.format(("setmetatable({filename=%s, line=%s, bytestart=%s, %s}" .. ", getmetatable(list()))"), filename, (form.line or "nil"), (form.bytestart or "nil"), mixed_concat(mapped, ", ")) + elseif utils["sequence?"](form) then + local mapped = utils.kvmap(form, entry_transform(q, q)) + local source = getmetatable(form) + local filename = nil + if source.filename then + filename = string.format("%q", source.filename) + else + filename = "nil" + end + local _1_ + if source then + _1_ = source.line + else + _1_ = "nil" + end + return string.format("setmetatable({%s}, {filename=%s, line=%s, sequence=%s})", mixed_concat(mapped, ", "), filename, _1_, "(getmetatable(sequence()))['sequence']") elseif (type(form) == "table") then local mapped = utils.kvmap(form, entry_transform(q, q)) local source = getmetatable(form) @@ -2748,7 +2888,7 @@ package.preload["fennel.friend"] = package.preload["fennel.friend"] 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 not to return a coroutine or userdata"}, ["could not read number (.*)"] = {"removing the non-digit character", "beginning the identifier with a non-digit if it is not meant to be a number"}, ["expected a function.* to call"] = {"removing the empty parentheses", "using square brackets if you want an empty table"}, ["expected binding table"] = {"placing a table here in square brackets containing identifiers to bind"}, ["expected body expression"] = {"putting some code in the body of this form after the bindings"}, ["expected each macro to be function"] = {"ensuring that the value for each key in your macros table contains a function", "avoid defining nested macro tables"}, ["expected even number of name/value bindings"] = {"finding where the identifier or value is missing"}, ["expected even number of values in table literal"] = {"removing a key", "adding a value"}, ["expected local"] = {"looking for a typo", "looking for a local which is used out of its scope"}, ["expected macros to be table"] = {"ensuring your macro definitions return a table"}, ["expected parameters"] = {"adding function parameters as a list of identifiers in brackets"}, ["expected rest argument before last parameter"] = {"moving & to right before the final identifier when destructuring"}, ["expected symbol for function parameter: (.*)"] = {"changing %s to an identifier instead of a literal value"}, ["expected var (.*)"] = {"declaring %s using var instead of let/local", "introducing a new local instead of changing the value of %s"}, ["expected vararg as last parameter"] = {"moving the \"...\" to the end of the parameter list"}, ["expected whitespace before opening delimiter"] = {"adding whitespace"}, ["global (.*) conflicts with local"] = {"renaming local %s"}, ["illegal character: (.)"] = {"deleting or replacing %s", "avoiding reserved characters like \", \\, ', ~, ;, @, `, and comma"}, ["local (.*) was overshadowed by a special form or macro"] = {"renaming local %s"}, ["macro not found in macro module"] = {"checking the keys of the imported macro module's returned table"}, ["macro tried to bind (.*) without gensym"] = {"changing to %s# when introducing identifiers inside macros"}, ["malformed multisym"] = {"ensuring each period or colon is not followed by another period or colon"}, ["may only be used at compile time"] = {"moving this to inside a macro if you need to manipulate symbols/lists", "using square brackets instead of parens to construct a table"}, ["method must be last component"] = {"using a period instead of a colon for field access", "removing segments after the colon", "making the method call, then looking up the field on the result"}, ["mismatched closing delimiter (.), expected (.)"] = {"replacing %s with %s", "deleting %s", "adding matching opening delimiter earlier"}, ["multisym method calls may only be in call position"] = {"using a period instead of a colon to reference a table's fields", "putting parens around this"}, ["unable to bind (.*)"] = {"replacing the %s with an identifier"}, ["unexpected closing delimiter (.)"] = {"deleting %s", "adding matching opening delimiter earlier"}, ["unexpected multi symbol (.*)"] = {"removing periods or colons from %s"}, ["unexpected vararg"] = {"putting \"...\" at the end of the fn parameters if the vararg was intended"}, ["unknown global in strict mode: (.*)"] = {"looking to see if there's a typo", "using the _G table instead, eg. _G.%s if you really want a global", "moving this code to somewhere that %s is in scope", "binding %s as a local in the scope of this code"}, ["unused local (.*)"] = {"fixing a typo so %s is used", "renaming the local to _%s"}, ["use of global (.*) is aliased by a local"] = {"renaming local %s", "refer to the global using _G.%s instead of directly"}} + local 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 unpack = (table.unpack or _G.unpack) local function suggest(msg) local suggestion = nil @@ -2780,21 +2920,19 @@ package.preload["fennel.friend"] = package.preload["fennel.friend"] or function( f:close() return codeline, bytes end - local function read_line_from_source(source, line) - local lines, bytes, codeline = 0, 0 - for this_line, newline in string.gmatch((source .. "\n"), "(.-)(\13?\n)") do - lines = (lines + 1) - if (lines == line) then - codeline = this_line - break - end - bytes = (bytes + #newline + #this_line) + local function read_line_from_string(matcher, target_line, _3fcurrent_line, _3fbytes) + local this_line, newline = matcher() + local current_line = (_3fcurrent_line or 1) + local bytes = ((_3fbytes or 0) + #this_line + #newline) + if (target_line == current_line) then + return this_line, bytes + elseif this_line then + return read_line_from_string(matcher, target_line, (current_line + 1), bytes) end - return codeline, bytes end local function read_line(filename, line, source) if source then - return read_line_from_source(source, line) + return read_line_from_string(string.gmatch((source .. "\n"), "(.-)(\13?\n)"), line) else return read_line_from_file(filename, line) end @@ -2927,6 +3065,7 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( end return r end + assert(((nil == filename) or ("string" == type(filename))), "expected filename as second argument to parser") local function parse_error(msg, byteindex_override) local _0_ = (options or utils.root.options or {}) local source = _0_["source"] @@ -2947,8 +3086,17 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( return nil elseif ((type(_0_0) == "table") and (nil ~= _0_0.prefix)) then local prefix = _0_0.prefix - table.remove(stack) - return dispatch(utils.list(utils.sym(prefix), v)) + local source = nil + do + local _1_0 = table.remove(stack) + _1_0["byteend"] = byteindex + source = _1_0 + end + local list = utils.list(utils.sym(prefix, source), v) + for k, v0 in pairs(source) do + list[k] = v0 + end + return dispatch(list) elseif (nil ~= _0_0) then local top = _0_0 whitespace_since_dispatch = false @@ -2984,7 +3132,7 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( end return parse_comment(getb(), _1_()) elseif (options and options.comments) then - return dispatch(utils.comment(table.concat(contents))) + return dispatch(utils.comment(table.concat(contents), {filename = filename, line = (line - 1)})) else return b end @@ -3005,7 +3153,49 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( end return dispatch(val) end + 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 + 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 + 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 + add_comment_at(comments.values, next_noncomment(tbl, i), node) + else + add_comment_at(comments.keys, next_noncomment(tbl, i), node) + end + end + for i = #tbl, 1, -1 do + if utils["comment?"](tbl[i]) then + table.remove(tbl, i) + end + end + return comments + end local function close_curly_table(tbl) + local comments = extract_comments(tbl) + local keys = {} local val = {} if ((#tbl % 2) ~= 0) then byteindex = (byteindex - 1) @@ -3017,7 +3207,10 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( tbl[i] = tostring(tbl[(i + 1)]) end val[tbl[i]] = tbl[(i + 1)] + table.insert(keys, tbl[i]) end + tbl.comments = comments + tbl.keys = keys return dispatch(val) end local function close_table(b) @@ -3025,7 +3218,7 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( if (top == nil) then parse_error(("unexpected closing delimiter " .. string.char(b))) end - if (top.closer ~= b) then + if (top.closer and (top.closer ~= b)) then parse_error(("mismatched closing delimiter " .. string.char(b) .. ", expected " .. string.char(top.closer))) end top.byteend = byteindex @@ -3073,9 +3266,9 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( return dispatch(load_fn()) end local function parse_prefix(b) - table.insert(stack, {prefix = prefixes[b]}) + table.insert(stack, {bytestart = byteindex, filename = filename, line = line, prefix = prefixes[b]}) local nextb = getb() - if whitespace_3f(nextb) then + if (whitespace_3f(nextb) or (true == delims[nextb])) then if (b ~= 35) then parse_error("invalid whitespace after quoting prefix") end @@ -3116,11 +3309,13 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] 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) @@ -3134,12 +3329,8 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] 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) @@ -3185,19 +3376,27 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] 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 succ[k] = keys[(i + 1)] end local function stablenext(tbl, idx) + local key = nil if (idx == nil) then - return keys[1], tbl[keys[1]] + key = keys[1] else - return succ[idx], tbl[succ[idx]] + key = succ[idx] end + local value = nil + if (key == nil) then + value = nil + else + value = tbl[key] + end + return key, value end return stablenext, t, nil end @@ -3207,9 +3406,8 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] 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 @@ -3228,9 +3426,8 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] 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 @@ -3302,10 +3499,19 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. end return ("(" .. table.concat(map(safe, (tostring2 or tostring)), " ", 1, max) .. ")") end - local symbol_mt = {"SYMBOL", __fennelview = deref, __tostring = deref} + local function comment_view(c) + return c, true + end + local function sym_3d(a, b) + return ((deref(a) == deref(b)) and (getmetatable(a) == getmetatable(b))) + end + local function sym_3c(a, b) + return (a[1] < tostring(b)) + end + local symbol_mt = {"SYMBOL", __eq = sym_3d, __fennelview = deref, __lt = sym_3c, __tostring = deref} local expr_mt = {"EXPR", __tostring = deref} local list_mt = {"LIST", __fennelview = list__3estring, __tostring = list__3estring} - local comment_mt = {"COMMENT", __fennelview = deref, __tostring = deref} + local comment_mt = {"COMMENT", __eq = sym_3d, __fennelview = comment_view, __lt = sym_3c, __tostring = deref} local sequence_marker = {"SEQUENCE"} local vararg = setmetatable({"..."}, {"VARARG", __fennelview = deref, __tostring = deref}) local getenv = nil @@ -3320,9 +3526,9 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] 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 @@ -3336,8 +3542,11 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. local function expr(strcode, etype) return setmetatable({strcode, type = etype}, expr_mt) end - local function comment_2a(contents) - return setmetatable({contents}, comment_mt) + 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) end local function varg() return vararg @@ -3354,9 +3563,6 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] 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) @@ -3364,6 +3570,9 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] 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)) @@ -3450,7 +3659,7 @@ local compiler = require("fennel.compiler") local specials = require("fennel.specials") local repl = require("fennel.repl") local view = require("fennel.view") -local function get_env(env) +local function eval_env(env) if (env == "_COMPILER") then local env0 = specials["make-compiler-env"](nil, compiler.scopes.compiler, {}) local mt = getmetatable(env0) @@ -3460,26 +3669,32 @@ local function get_env(env) return (env and specials["wrap-env"](env)) end end -local function eval(str, options, ...) +local function eval_opts(options, str) local opts = utils.copy(options) - local _ = nil if ((opts.allowedGlobals == nil) and not getmetatable(opts.env)) then opts.allowedGlobals = specials["current-global-names"](opts.env) - _ = nil - else - _ = nil end - local env = get_env(opts.env) + 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 lua_source = compiler["compile-string"](str, opts) local loader = nil - local function _1_(...) + local function _0_(...) if opts.filename then return ("@" .. opts.filename) else return str end end - loader = specials["load-code"](lua_source, env, _1_(...)) + loader = specials["load-code"](lua_source, env, _0_(...)) opts.filename = nil return loader(...) end @@ -3491,7 +3706,7 @@ local function dofile_2a(filename, options, ...) opts.filename = filename return eval(source, opts, ...) end -local mod = {["compile-stream"] = compiler["compile-stream"], ["compile-string"] = compiler["compile-string"], ["list?"] = utils["list?"], ["load-code"] = specials["load-code"], ["macro-loaded"] = specials["macro-loaded"], ["make-searcher"] = specials["make-searcher"], ["search-module"] = specials["search-module"], ["sequence?"] = utils["sequence?"], ["string-stream"] = parser["string-stream"], ["sym-char?"] = parser["sym-char?"], ["sym?"] = utils["sym?"], compile = compiler.compile, compile1 = compiler.compile1, compileStream = compiler["compile-stream"], compileString = compiler["compile-string"], doc = specials.doc, dofile = dofile_2a, eval = eval, gensym = compiler.gensym, granulate = parser.granulate, list = utils.list, loadCode = specials["load-code"], macroLoaded = specials["macro-loaded"], makeSearcher = specials["make-searcher"], make_searcher = specials["make-searcher"], mangle = compiler["global-mangling"], metadata = compiler.metadata, parser = parser.parser, path = utils.path, repl = repl, scope = compiler["make-scope"], searchModule = specials["search-module"], searcher = specials["make-searcher"](), sequence = utils.sequence, stringStream = parser["string-stream"], sym = utils.sym, traceback = compiler.traceback, unmangle = compiler["global-unmangling"], varg = utils.varg, version = "0.9.0-dev", view = view} +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-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, traceback = compiler.traceback, unmangle = compiler["global-unmangling"], varg = utils.varg, version = "0.9.0", view = view} utils["fennel-module"] = mod do local builtin_macros = [===[;; This module contains all the built-in Fennel macros. Unlike all the other @@ -3504,7 +3719,7 @@ do ;; TODO: some of these macros modify their arguments; we should stop doing that, ;; but in a way that preserves file/line metadata. - (fn -> [val ...] + (fn ->* [val ...] "Thread-first macro. Take the first value and splice it into the second form as its first argument. The value of the second form is spliced into the first arg of the third, etc." @@ -3515,7 +3730,7 @@ do (set x elt))) x) - (fn ->> [val ...] + (fn ->>* [val ...] "Thread-last macro. Same as ->, except splices the value into the last position of each form rather than the first." @@ -3526,7 +3741,7 @@ do (set x elt))) x) - (fn -?> [val ...] + (fn -?>* [val ...] "Nil-safe thread-first macro. Same as -> except will short-circuit with nil when it encounters a nil value." (if (= 0 (select "#" ...)) @@ -3541,7 +3756,7 @@ do (-?> ,el ,(unpack els)) ,tmp))))) - (fn -?>> [val ...] + (fn -?>>* [val ...] "Nil-safe thread-last macro. Same as ->> except will short-circuit with nil when it encounters a nil value." (if (= 0 (select "#" ...)) @@ -3556,7 +3771,14 @@ do (-?>> ,el ,(unpack els)) ,tmp))))) - (fn doto [val ...] + (fn ?dot [tbl k ...] + "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# ,...))))) + + (fn doto* [val ...] "Evaluates val and splices it into the first argument of subsequent forms." (let [name (gensym) form `(let [,name ,val])] @@ -3566,28 +3788,32 @@ do (table.insert form name) form)) - (fn when [condition body1 ...] + (fn when* [condition body1 ...] "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 ...] + (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 ...] + (fn collect* [iter-tbl key-value-expr ...] "Returns a table made by running an iterator and evaluating an expression that returns key-value pairs to be inserted sequentially into the table. This can be thought of as a \"table comprehension\". The provided key-value @@ -3600,8 +3826,7 @@ do {: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# {}] @@ -3610,7 +3835,7 @@ do (k# v#) (tset tbl# k# v#))) tbl#)) - (fn icollect [iter-tbl value-expr ...] + (fn icollect* [iter-tbl value-expr ...] "Returns a sequential table made by running an iterator and evaluating an expression that returns values to be inserted sequentially into the table. This can be thought of as a \"list comprehension\". @@ -3621,8 +3846,7 @@ do [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# []] @@ -3630,13 +3854,15 @@ do (tset tbl# (+ (length tbl#) 1) ,value-expr)) tbl#)) - (fn partial [f ...] + (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))) + `(fn [,_VARARG] + ,body))) - (fn pick-args [n f] + (fn pick-args* [n f] "Creates a function of arity n that applies its arguments to f. For example, @@ -3644,12 +3870,14 @@ do expands to (fn [_0_ _1_] (func _0_ _1_))" (assert (and (= (type n) :number) (= n (math.floor n)) (>= n 0)) - "Expected n to be an integer literal >= 0.") + (.. "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 ...] + (fn pick-values* [n ...] "Like the `values` special, but emits exactly n values. For example, @@ -3658,14 +3886,16 @@ do (let [(_0_ _1_) ...] (values _0_ _1_))" (assert (and (= :number (type n)) (>= n 0) (= n (math.floor n))) - "Expected n to be an integer >= 0") - (let [let-syms (list) - let-values (if (= 1 (select :# ...)) ... `(values ,...))] - (for [i 1 n] (table.insert let-syms (gensym))) + (.. "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))) (if (= n 0) `(values) - `(let [,let-syms ,let-values] (values ,(unpack let-syms)))))) + `(let [,let-syms ,let-values] + (values ,(unpack let-syms)))))) - (fn lambda [...] + (fn lambda* [...] "Function literal with arity checking. Will throw an exception if a declared argument is passed in as nil, unless that argument name begins with ?." @@ -3673,23 +3903,25 @@ do 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)) @@ -3697,27 +3929,27 @@ do (table.insert args (sym :nil))) `(fn ,(unpack args)))) - (fn macro [name ...] + (fn macro* [name ...] "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?] + (fn macrodebug* [form return?] "Print the resulting form after performing macroexpansion. With a second argument, returns expanded form as a string instead of printing." (let [handle (if return? `do `print)] `(,handle ,(view (macroexpand form _SCOPE))))) - (fn import-macros [binding1 module-name1 ...] + (fn import-macros* [binding1 module-name1 ...] "Binds a table of macros from each macro module according to a binding form. Each binding form can be either a symbol or a k/v destructuring table. 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 @@ -3727,10 +3959,10 @@ do (_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))) - + (do + (tset scope.macros (. binding 1) {}) + (each [k v (pairs subscope.macros)] + (tset (. scope.macros (. binding 1)) k v))) ;; 1-level table destructuring for importing individual macros (table? binding) (each [macro-name [import-key] (pairs binding)] @@ -3757,16 +3989,26 @@ do (let [condition `(and (= (type ,val) :table)) bindings []] (each [k pat (pairs pattern)] - (if (and (sym? pat) (= "&" (tostring pat))) - (do (assert (not (. pattern (+ k 2))) - "expected rest argument before last parameter") - (table.insert bindings (. pattern (+ k 1))) - (table.insert bindings [`(select ,k ((or table.unpack - _G.unpack) - ,val))])) - (and (= :number (type k)) - (= "&" (tostring (. pattern (- k 1))))) - nil ; don't process the pattern right after &; already got it + (if (= pat `&) + (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)] @@ -3784,11 +4026,9 @@ do ;; 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))) @@ -3797,18 +4037,17 @@ do (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) (sym? (. pattern 2)) (= :? (tostring (. pattern 2)))) + (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 + (for [i 3 (length pattern)] ; splice in guard clauses (table.insert condition (. pattern i))) - (values `(let ,bindings ,condition) bindings)) - + (values `(let ,bindings + ,condition) bindings)) ;; multi-valued patterns (represented as lists) (list? pattern) (match-values vals pattern unifications match-pattern) @@ -3821,14 +4060,15 @@ do (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] @@ -3841,22 +4081,101 @@ do (tset syms valnum (gensym)))))) syms)) - (fn match [val ...] - "Perform pattern matching on val. See reference for details." + (fn match* [val ...] + ;; Old implementation of match macro, which doesn't directly support + ;; `where' and `or'. New syntax is implemented in `match-where', + ;; which simply generates old syntax and feeds it to `match*'. (let [clauses [...] 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)))) - {: -> : ->> : -?> : -?>> - : doto : when : with-open - : collect : icollect - : partial : lambda - : pick-args : pick-values - : macro : macrodebug : import-macros - : match} + ;; Construction of old match syntax from new syntax + + (fn partition-2 [seq] + ;; Partition `seq` by 2. + ;; If `seq` has odd amount of elements, the last one is dropped. + ;; + ;; Input: [1 2 3 4 5] + ;; Output: [[1 2] [3 4]] + (let [firsts [] + seconds [] + res []] + (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)))) + (each [i v1 (ipairs firsts)] + (let [v2 (. seconds i)] + (if (not= nil v2) + (table.insert res [v1 v2])))) + res)) + + (fn transform-or [[_ & pats] guards] + ;; Transforms `(or pat pats*)` lists into match `guard` patterns. + ;; + ;; (or pat1 pat2), guard => [(pat1 ? guard) (pat2 ? guard)] + (let [res []] + (each [_ pat (ipairs pats)] + (table.insert res (list pat `? (unpack guards)))) + res)) + + (fn transform-cond [cond] + ;; Transforms `where` cond into sequence of `match` guards. + ;; + ;; pat => [pat] + ;; (where pat guard) => [(pat ? guard)] + ;; (where (or pat1 pat2) guard) => [(pat1 ? guard) (pat2 ? guard)] + (if (and (list? cond) (= (. cond 1) `where)) + (let [second (. cond 2)] + (if (and (list? second) (= (. second 1) `or)) + (transform-or second [(unpack cond 3)]) + :else + [(list second `? (unpack cond 3))])) + :else + [cond])) + + (fn match-where [val ...] + "Perform pattern matching on val. See reference for details. + + Syntax: + + (match data-expression + pattern body + (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 "#" ...) ...)) + match-body []] + (each [_ [cond body] (ipairs conds-bodies)] + (each [_ cond (ipairs (transform-cond cond))] + (table.insert match-body cond) + (table.insert match-body body))) + (if else-branch + (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* + :match match-where} ]===] local module_name = "fennel.macros" local _ = nil