From d173cb04113ea0316913dcb40a5c2779bf57e6e8 Mon Sep 17 00:00:00 2001 From: Sam Pagenkopf Date: Thu, 19 Sep 2024 15:23:40 -0500 Subject: [PATCH] update fennel to 1.5.1 --- src/lib/fennel | 5719 ++++++++++++++++++++++++-------------------- src/lib/fennel.lua | 5351 ++++++++++++++++++++++------------------- 2 files changed, 6007 insertions(+), 5063 deletions(-) diff --git a/src/lib/fennel b/src/lib/fennel index e991b5b..ae546d2 100755 --- a/src/lib/fennel +++ b/src/lib/fennel @@ -1,34 +1,43 @@ #!/usr/bin/env lua +-- SPDX-License-Identifier: MIT +-- SPDX-FileCopyrightText: Calvin Rose and contributors package.preload["fennel.binary"] = package.preload["fennel.binary"] or function(...) local fennel = require("fennel") - local _local_787_ = require("fennel.utils") - local warn = _local_787_["warn"] - local copy = _local_787_["copy"] + local _879_ = require("fennel.utils") + local copy = _879_["copy"] + local warn = _879_["warn"] local function shellout(command) local f = io.popen(command) local stdout = f:read("*all") return (f:close() and stdout) end local function execute(cmd) - local _788_ = os.execute(cmd) - if (_788_ == 0) then + local _880_0 = os.execute(cmd) + if (_880_0 == 0) then return true - elseif (_788_ == true) then + elseif (_880_0 == true) then return true - else - return nil end end local function string__3ec_hex_literal(characters) - local hex = {} - for character in characters:gmatch(".") do - table.insert(hex, ("0x%02x"):format(string.byte(character))) + local _882_ + do + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for character in characters:gmatch(".") do + local val_19_ = ("0x%02x"):format(string.byte(character)) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end + end + _882_ = tbl_17_ end - return table.concat(hex, ", ") + return table.concat(_882_, ", ") end local c_shim = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n#include \n#include \n#include \n#ifdef __cplusplus\n}\n#endif\n#include \n#include \n#include \n#include \n\n#if LUA_VERSION_NUM == 501\n #define LUA_OK 0\n#endif\n\n/* Copied from lua.c */\n\nstatic lua_State *globalL = NULL;\n\nstatic void lstop (lua_State *L, lua_Debug *ar) {\n (void)ar; /* unused arg. */\n lua_sethook(L, NULL, 0, 0); /* reset hook */\n luaL_error(L, \"interrupted!\");\n}\n\nstatic void laction (int i) {\n signal(i, SIG_DFL); /* if another SIGINT happens, terminate process */\n lua_sethook(globalL, lstop, LUA_MASKCALL | LUA_MASKRET | LUA_MASKCOUNT, 1);\n}\n\nstatic void createargtable (lua_State *L, char **argv, int argc, int script) {\n int i, narg;\n if (script == argc) script = 0; /* no script name? */\n narg = argc - (script + 1); /* number of positive indices */\n lua_createtable(L, narg, script + 1);\n for (i = 0; i < argc; i++) {\n lua_pushstring(L, argv[i]);\n lua_rawseti(L, -2, i - script);\n }\n lua_setglobal(L, \"arg\");\n}\n\nstatic int msghandler (lua_State *L) {\n const char *msg = lua_tostring(L, 1);\n if (msg == NULL) { /* is error object not a string? */\n if (luaL_callmeta(L, 1, \"__tostring\") && /* does it have a metamethod */\n lua_type(L, -1) == LUA_TSTRING) /* that produces a string? */\n return 1; /* that is the message */\n else\n msg = lua_pushfstring(L, \"(error object is a %%s value)\",\n luaL_typename(L, 1));\n }\n /* Call debug.traceback() instead of luaL_traceback() for Lua 5.1 compat. */\n lua_getglobal(L, \"debug\");\n lua_getfield(L, -1, \"traceback\");\n /* debug */\n lua_remove(L, -2);\n lua_pushstring(L, msg);\n /* original msg */\n lua_remove(L, -3);\n lua_pushinteger(L, 2); /* skip this function and traceback */\n lua_call(L, 2, 1); /* call debug.traceback */\n return 1; /* return the traceback */\n}\n\nstatic int docall (lua_State *L, int narg, int nres) {\n int status;\n int base = lua_gettop(L) - narg; /* function index */\n lua_pushcfunction(L, msghandler); /* push message handler */\n lua_insert(L, base); /* put it under function and args */\n globalL = L; /* to be available to 'laction' */\n signal(SIGINT, laction); /* set C-signal handler */\n status = lua_pcall(L, narg, nres, base);\n signal(SIGINT, SIG_DFL); /* reset C-signal handler */\n lua_remove(L, base); /* remove message handler from the stack */\n return status;\n}\n\nint main(int argc, char *argv[]) {\n lua_State *L = luaL_newstate();\n luaL_openlibs(L);\n createargtable(L, argv, argc, 0);\n\n static const unsigned char lua_loader_program[] = {\n%s\n};\n if(luaL_loadbuffer(L, (const char*)lua_loader_program,\n sizeof(lua_loader_program), \"%s\") != LUA_OK) {\n fprintf(stderr, \"luaL_loadbuffer: %%s\\n\", lua_tostring(L, -1));\n lua_close(L);\n return 1;\n }\n\n /* lua_bundle */\n lua_newtable(L);\n static const unsigned char lua_require_1[] = {\n %s\n };\n lua_pushlstring(L, (const char*)lua_require_1, sizeof(lua_require_1));\n lua_setfield(L, -2, \"%s\");\n\n%s\n\n if (docall(L, 1, LUA_MULTRET)) {\n const char *errmsg = lua_tostring(L, 1);\n if (errmsg) {\n fprintf(stderr, \"%%s\\n\", errmsg);\n }\n lua_close(L);\n return 1;\n }\n lua_close(L);\n return 0;\n}" local function compile_fennel(filename, options) - local f + local f = nil if (filename == "-") then f = io.stdin else @@ -39,18 +48,16 @@ package.preload["fennel.binary"] = package.preload["fennel.binary"] or function( return lua_code end local function module_name(open, rename, used_renames) - local require_name + local require_name = nil do - local _791_ = rename[open] - if (nil ~= _791_) then - local renamed = _791_ + local _885_0 = rename[open] + if (nil ~= _885_0) then + local renamed = _885_0 used_renames[open] = true require_name = renamed - elseif true then - local _ = _791_ - require_name = open else - require_name = nil + local _ = _885_0 + require_name = open end end return (require_name:sub(1, 1) .. require_name:sub(2):gsub("_", ".")) @@ -66,9 +73,8 @@ package.preload["fennel.binary"] = package.preload["fennel.binary"] or function( for open in shellout((nm .. " " .. path)):gmatch("[^dDt] _?luaopen_([%a%p%d]+)") do table.insert(opens, open) end - if (0 == #opens) then + if (nil == opens[1]) then warn((("Native module %s did not contain any luaopen_* symbols. " .. "Did you mean to use --native-library instead of --native-module?")):format(path)) - else end for _0, open in ipairs(opens) do table.insert(out, (" int luaopen_%s(lua_State *L);"):format(open)) @@ -79,7 +85,6 @@ package.preload["fennel.binary"] = package.preload["fennel.binary"] or function( for key, val in pairs(rename) do if not used_renames[key] then warn((("unused --rename-native-module %s %s argument. " .. "Did you mean to include a native module?")):format(key, val)) - else end end return table.concat(out, "\n") @@ -89,15 +94,15 @@ package.preload["fennel.binary"] = package.preload["fennel.binary"] or function( local basename_noextension = (basename:match("(.+)%.") or basename) local dotpath = filename:gsub("^%.%/", ""):gsub("[\\/]", ".") local dotpath_noextension = (dotpath:match("(.+)%.") or dotpath) - local fennel_loader - local _795_ + local fennel_loader = nil + local _889_ do - _795_ = "(do (local bundle_2_auto ...) (fn loader_3_auto [name_4_auto] (match (or (. bundle_2_auto name_4_auto) (. bundle_2_auto (.. name_4_auto \".init\"))) (mod_5_auto ? (= \"function\" (type mod_5_auto))) mod_5_auto (mod_5_auto ? (= \"string\" (type mod_5_auto))) (assert (if (= _VERSION \"Lua 5.1\") (loadstring mod_5_auto name_4_auto) (load mod_5_auto name_4_auto))) nil (values nil (: \"\n\\tmodule '%%s' not found in fennel bundle\" \"format\" name_4_auto)))) (table.insert (or package.loaders package.searchers) 2 loader_3_auto) ((assert (loader_3_auto \"%s\")) ((or unpack table.unpack) arg)))" + _889_ = "(do (local bundle_2_ ...) (fn loader_3_ [name_4_] (match (or (. bundle_2_ name_4_) (. bundle_2_ (.. name_4_ \".init\"))) (mod_5_ ? (= \"function\" (type mod_5_))) mod_5_ (mod_5_ ? (= \"string\" (type mod_5_))) (assert (if (= _VERSION \"Lua 5.1\") (loadstring mod_5_ name_4_) (load mod_5_ name_4_))) nil (values nil (: \"\n\\tmodule '%%s' not found in fennel bundle\" \"format\" name_4_)))) (table.insert (or package.loaders package.searchers) 2 loader_3_) ((assert (loader_3_ \"%s\")) ((or unpack table.unpack) arg)))" end - fennel_loader = _795_:format(dotpath_noextension) + fennel_loader = _889_:format(dotpath_noextension) local lua_loader = fennel["compile-string"](fennel_loader) - local _let_796_ = options - local rename_modules = _let_796_["rename-modules"] + local _890_ = options + local rename_modules = _890_["rename-modules"] return c_shim:format(string__3ec_hex_literal(lua_loader), basename_noextension, string__3ec_hex_literal(compile_fennel(filename, options)), dotpath_noextension, native_loader(native, {["rename-modules"] = rename_modules})) end local function write_c(filename, native, options) @@ -110,40 +115,37 @@ package.preload["fennel.binary"] = package.preload["fennel.binary"] or function( local function compile_binary(lua_c_path, executable_name, static_lua, lua_include_dir, native) local cc = (os.getenv("CC") or "cc") local rdynamic, bin_extension, ldl_3f = nil, nil, nil - local _798_ + local _892_ do - local _797_ = shellout((cc .. " -dumpmachine")) - if (nil ~= _797_) then - _798_ = _797_:match("mingw") + local _891_0 = shellout((cc .. " -dumpmachine")) + if (nil ~= _891_0) then + _892_ = _891_0:match("mingw") else - _798_ = _797_ + _892_ = _891_0 end end - if _798_ then + if _892_ then rdynamic, bin_extension, ldl_3f = "", ".exe", false else rdynamic, bin_extension, ldl_3f = "-rdynamic", "", true end - local compile_command - local _801_ + local compile_command = nil + local _895_ if ldl_3f then - _801_ = "-ldl" + _895_ = "-ldl" else - _801_ = "" + _895_ = "" end - compile_command = {cc, "-Os", lua_c_path, table.concat(native, " "), static_lua, rdynamic, "-lm", _801_, "-o", (executable_name .. bin_extension), "-I", lua_include_dir, os.getenv("CC_OPTS")} + compile_command = {cc, "-Os", lua_c_path, table.concat(native, " "), static_lua, rdynamic, "-lm", _895_, "-o", (executable_name .. bin_extension), "-I", lua_include_dir, os.getenv("CC_OPTS")} if os.getenv("FENNEL_DEBUG") then print("Compiling with", table.concat(compile_command, " ")) - else end if not execute(table.concat(compile_command, " ")) then print("failed:", table.concat(compile_command, " ")) os.exit(1) - else end if not os.getenv("FENNEL_DEBUG") then os.remove(lua_c_path) - else end return os.exit(0) end @@ -152,58 +154,52 @@ package.preload["fennel.binary"] = package.preload["fennel.binary"] or function( if (version_extension and (version_extension ~= "") and not version_extension:match("%.%d+")) then return false else - local _806_ = extension - if (_806_ == "a") then + local _900_0 = extension + if (_900_0 == "a") then return path - elseif (_806_ == "o") then + elseif (_900_0 == "o") then return path - elseif (_806_ == "so") then + elseif (_900_0 == "so") then return path - elseif (_806_ == "dylib") then + elseif (_900_0 == "dylib") then return path - elseif true then - local _ = _806_ - return false else - return nil + local _ = _900_0 + return false end end end local function extract_native_args(args) - local native = {modules = {}, libraries = {}, ["rename-modules"] = {}} + local native = {["rename-modules"] = {}, libraries = {}, modules = {}} for i = #args, 1, -1 do if ("--native-module" == args[i]) then local path = assert(native_path_3f(table.remove(args, (i + 1)))) table.insert(native.modules, 1, path) table.insert(native.libraries, 1, path) table.remove(args, i) - else end if ("--native-library" == args[i]) then table.insert(native.libraries, 1, assert(native_path_3f(table.remove(args, (i + 1))))) table.remove(args, i) - else end if ("--rename-native-module" == args[i]) then local original = table.remove(args, (i + 1)) local new = table.remove(args, (i + 1)) - do end (native["rename-modules"])[original] = new + native["rename-modules"][original] = new table.remove(args, i) - else end end - if (0 < #args) then + if next(args) then print(table.concat(args, " ")) error(("Unknown args: " .. table.concat(args, " "))) - else end return native end local function compile(filename, executable_name, static_lua, lua_include_dir, options, args) - local _let_813_ = extract_native_args(args) - local modules = _let_813_["modules"] - local libraries = _let_813_["libraries"] - local rename_modules = _let_813_["rename-modules"] + local _907_ = extract_native_args(args) + local libraries = _907_["libraries"] + local modules = _907_["modules"] + local rename_modules = _907_["rename-modules"] local opts = {["rename-modules"] = rename_modules} copy(options, opts) return compile_binary(write_c(filename, modules, opts), executable_name, static_lua, lua_include_dir, libraries) @@ -211,23 +207,23 @@ package.preload["fennel.binary"] = package.preload["fennel.binary"] or function( local help = "\nUsage: %s --compile-binary FILE OUT STATIC_LUA_LIB LUA_INCLUDE_DIR\n\nCompile a binary from your Fennel program.\n\nRequires a C compiler, a copy of liblua, and Lua's dev headers. Implies\nthe --require-as-include option.\n\n FILE: the Fennel source being compiled.\n OUT: the name of the executable to generate\n STATIC_LUA_LIB: the path to the Lua library to use in the executable\n LUA_INCLUDE_DIR: the path to the directory of Lua C header files\n\nFor example, on a Debian system, to compile a file called program.fnl using\nLua 5.3, you would use this:\n\n $ %s --compile-binary program.fnl program \\\n /usr/lib/x86_64-linux-gnu/liblua5.3.a /usr/include/lua5.3\n\nThe program will be compiled to Lua, then compiled to C, then compiled to\nmachine code. You can set the CC environment variable to change the compiler\nused (default: cc) or set CC_OPTS to pass in compiler options. For example\nset CC_OPTS=-static to generate a binary with static linking.\n\nThis method is currently limited to programs do not transitively require Lua\nmodules. Requiring a Lua module directly will work, but requiring a Lua module\nwhich requires another will fail.\n\nTo include C libraries that contain Lua modules, add --native-module path/to.so,\nand to include C libraries without modules, use --native-library path/to.so.\nThese options are unstable, barely tested, and even more likely to break.\n\nIf you need to change the require name that a given native module is referenced\nas, you can use the --rename-native-module ORIGINAL NEW. ORIGINAL should be the\nsuffix of the luaopen_* symbol in the native module. NEW should be the string\nyou wish to pass to require to require the given native module. This can be used\nto handle cases where the name of an object file does not match the name of the\nluaopen_* symbol(s) within it. For example, the Lua readline bindings include a\nreadline.lua file which is usually required as \"readline\", and a C-readline.so\nfile which is required in the Lua half of the bindings like so:\n\n require 'C-readline'\n\nHowever, the symbol within the C-readline.so file is named luaopen_readline, so\nby default --compile-binary will make it so you can require it as \"readline\",\nwhich collides with the name of the readline.lua file and doesn't match the\nrequire call within readline.lua. In order to include the module within your\ncompiled binary and have it get picked up by readline.lua correctly, you can\nspecify the name used to refer to it in a require call by compiling it like\nso (this is assuming that program.fnl requires the Lua bindings):\n\n $ %s --compile-binary program.fnl program \\\n /usr/lib/x86_64-linux-gnu/liblua5.3.a /usr/include/lua5.3 \\\n --native-module C-readline.so \\\n --rename-native-module readline C-readline\n" return {compile = compile, help = help} end -local fennel +local fennel = nil package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) local utils = require("fennel.utils") local parser = require("fennel.parser") local compiler = require("fennel.compiler") local specials = require("fennel.specials") local view = require("fennel.view") - local unpack = (table.unpack or _G.unpack) - local function default_read_chunk(parser_state) - local function _631_() - if (0 < parser_state["stack-size"]) then - return ".." - else - return ">> " - end + local depth = 0 + local function prompt_for(top_3f) + if top_3f then + return (string.rep(">", (depth + 1)) .. " ") + else + return (string.rep(".", (depth + 1)) .. " ") end - io.write(_631_()) + end + local function default_read_chunk(parser_state) + io.write(prompt_for((0 == parser_state["stack-size"]))) io.flush() local input = io.read() return (input and (input .. "\n")) @@ -236,85 +232,78 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) io.write(table.concat(xs, "\9")) return io.write("\n") end - local function default_on_error(errtype, err, lua_source) - local function _633_() - local _632_ = errtype - if (_632_ == "Lua Compile") then - return ("Bad code generated - likely a bug with the compiler:\n" .. "--- Generated Lua Start ---\n" .. lua_source .. "--- Generated Lua End ---\n") - elseif (_632_ == "Runtime") then + local function default_on_error(errtype, err) + local function _702_() + local _701_0 = errtype + if (_701_0 == "Runtime") then return (compiler.traceback(tostring(err), 4) .. "\n") - elseif true then - local _ = _632_ - return ("%s error: %s\n"):format(errtype, tostring(err)) else - return nil + local _ = _701_0 + return ("%s error: %s\n"):format(errtype, tostring(err)) end end - return io.write(_633_()) + return io.write(_702_()) end local function splice_save_locals(env, lua_source, scope) - local saves + local saves = nil do - local tbl_16_auto = {} - local i_17_auto = #tbl_16_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ for name in pairs(env.___replLocals___) do - local val_18_auto = ("local %s = ___replLocals___['%s']"):format(name, name) - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + local val_19_ = ("local %s = ___replLocals___[%q]"):format((scope.manglings[name] or name), name) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - saves = tbl_16_auto + saves = tbl_17_ end - local binds + local binds = nil do - local tbl_16_auto = {} - local i_17_auto = #tbl_16_auto - for _, name in pairs(scope.manglings) do - local val_18_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for raw, name in pairs(scope.manglings) do + local val_19_ = nil if not scope.gensyms[name] then - val_18_auto = ("___replLocals___['%s'] = %s"):format(name, name) + val_19_ = ("___replLocals___[%q] = %s"):format(raw, name) else - val_18_auto = nil + val_19_ = nil end - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - binds = tbl_16_auto + binds = tbl_17_ end - local gap + local gap = nil if lua_source:find("\n") then gap = "\n" else gap = " " end - local function _639_() + local function _708_() if next(saves) then return (table.concat(saves, " ") .. gap) else return "" end end - local function _642_() - local _640_, _641_ = lua_source:match("^(.*)[\n ](return .*)$") - if ((nil ~= _640_) and (nil ~= _641_)) then - local body = _640_ - local _return = _641_ + local function _711_() + local _709_0, _710_0 = lua_source:match("^(.*)[\n ](return .*)$") + if ((nil ~= _709_0) and (nil ~= _710_0)) then + local body = _709_0 + local _return = _710_0 return (body .. gap .. table.concat(binds, " ") .. gap .. _return) - elseif true then - local _ = _640_ - return lua_source else - return nil + local _ = _709_0 + return lua_source end end - return (_639_() .. _642_()) + return (_708_() .. _711_()) end - local function completer(env, scope, text) + local commands = {} + local function completer(env, scope, text, _3ffulltext, _from, _to) local max_items = 2000 local seen = {} local matches = {} @@ -322,20 +311,20 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) local stop_looking_3f = false local function add_partials(input, tbl, prefix) local scope_first_3f = ((tbl == env) or (tbl == env.___replLocals___)) - local tbl_16_auto = matches - local i_17_auto = #tbl_16_auto - local function _644_() + local tbl_17_ = matches + local i_18_ = #tbl_17_ + local function _713_() if scope_first_3f then return scope.manglings else return tbl end end - for k, is_mangled in utils.allpairs(_644_()) do + for k, is_mangled in utils.allpairs(_713_()) do if (max_items <= #matches) then break end - local val_18_auto + local val_19_ = nil do - local lookup_k + local lookup_k = nil if scope_first_3f then lookup_k = is_mangled else @@ -343,21 +332,20 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) end if ((type(k) == "string") and (input == k:sub(0, #input)) and not seen[k] and ((":" ~= prefix:sub(-1)) or ("function" == type(tbl[lookup_k])))) then seen[k] = true - val_18_auto = (prefix .. k) + val_19_ = (prefix .. k) else - val_18_auto = nil + val_19_ = nil end end - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - return tbl_16_auto + return tbl_17_ end local function descend(input, tbl, prefix, add_matches, method_3f) - local splitter + local splitter = nil if method_3f then splitter = "^([^:]+):(.*)" else @@ -372,12 +360,10 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) else return add_matches(tail, tbl[raw_head], (prefix .. head)) end - else - return nil end end local function add_matches(input, tbl, prefix) - local prefix0 + local prefix0 = nil if prefix then prefix0 = (prefix .. ".") else @@ -391,102 +377,114 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) return descend(input, tbl, prefix0, add_matches, false) end end - for _, source in ipairs({scope.specials, scope.macros, (env.___replLocals___ or {}), env, env._G}) do - if stop_looking_3f then break end - add_matches(input_fragment, source) + do + local _722_0 = tostring((_3ffulltext or text)):match("^%s*,([^%s()[%]]*)$") + if (nil ~= _722_0) then + local cmd_fragment = _722_0 + add_partials(cmd_fragment, commands, ",") + else + local _ = _722_0 + for _0, source in ipairs({scope.specials, scope.macros, (env.___replLocals___ or {}), env, env._G}) do + if stop_looking_3f then break end + add_matches(input_fragment, source) + end + end end return matches end - local commands = {} local function command_3f(input) return input:match("^%s*,") end local function command_docs() - local _653_ + local _724_ do - local tbl_16_auto = {} - local i_17_auto = #tbl_16_auto - for name, f in pairs(commands) do - local val_18_auto = (" ,%s - %s"):format(name, ((compiler.metadata):get(f, "fnl/docstring") or "undocumented")) - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for name, f in utils.stablepairs(commands) do + local val_19_ = (" ,%s - %s"):format(name, ((compiler.metadata):get(f, "fnl/docstring") or "undocumented")) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - _653_ = tbl_16_auto + _724_ = tbl_17_ end - return table.concat(_653_, "\n") + return table.concat(_724_, "\n") end commands.help = function(_, _0, on_values) - return on_values({("Welcome to Fennel.\nThis is the REPL where you can enter code to be evaluated.\nYou can also run these repl commands:\n\n" .. command_docs() .. "\n ,exit - Leave the repl.\n\nUse ,doc something to see descriptions for individual macros and special forms.\n\nFor more information about the language, see https://fennel-lang.org/reference")}) + return on_values({("Welcome to Fennel.\nThis is the REPL where you can enter code to be evaluated.\nYou can also run these repl commands:\n\n" .. command_docs() .. "\n ,return FORM - Evaluate FORM and return its value to the REPL's caller.\n ,exit - Leave the repl.\n\nUse ,doc something to see descriptions for individual macros and special forms.\nValues from previous inputs are kept in *1, *2, and *3.\n\nFor more information about the language, see https://fennel-lang.org/reference")}) end do end (compiler.metadata):set(commands.help, "fnl/docstring", "Show this message.") local function reload(module_name, env, on_values, on_error) - local _655_, _656_ = pcall(specials["load-code"]("return require(...)", env), module_name) - if ((_655_ == true) and (nil ~= _656_)) then - local old = _656_ - local _ + local _726_0, _727_0 = pcall(specials["load-code"]("return require(...)", env), module_name) + if ((_726_0 == true) and (nil ~= _727_0)) then + local old = _727_0 + local _ = nil package.loaded[module_name] = nil _ = nil - local ok, new = pcall(require, module_name) - local new0 - if not ok then - on_values({new}) - new0 = old - else - new0 = new + local new = nil + do + local _728_0, _729_0 = pcall(require, module_name) + if ((_728_0 == true) and (nil ~= _729_0)) then + local new0 = _729_0 + new = new0 + elseif (true and (nil ~= _729_0)) then + local _0 = _728_0 + local msg = _729_0 + on_error("Repl", msg) + new = old + else + new = nil + end end specials["macro-loaded"][module_name] = nil - if ((type(old) == "table") and (type(new0) == "table")) then - for k, v in pairs(new0) do + if ((type(old) == "table") and (type(new) == "table")) then + for k, v in pairs(new) do old[k] = v end for k in pairs(old) do - if (nil == (new0)[k]) then + if (nil == new[k]) then old[k] = nil - else end end package.loaded[module_name] = old - else end return on_values({"ok"}) - elseif ((_655_ == false) and (nil ~= _656_)) then - local msg = _656_ + elseif ((_726_0 == false) and (nil ~= _727_0)) then + local msg = _727_0 if msg:match("loop or previous error loading module") then package.loaded[module_name] = nil return reload(module_name, env, on_values, on_error) - elseif (specials["macro-loaded"])[module_name] then + elseif specials["macro-loaded"][module_name] then specials["macro-loaded"][module_name] = nil return nil else - local function _661_() - local _660_ = msg:gsub("\n.*", "") - return _660_ + local function _734_() + local _733_0 = msg:gsub("\n.*", "") + return _733_0 end - return on_error("Runtime", _661_()) + return on_error("Runtime", _734_()) end - else - return nil end end local function run_command(read, on_error, f) - local _664_, _665_, _666_ = pcall(read) - if ((_664_ == true) and (_665_ == true) and (nil ~= _666_)) then - local val = _666_ - return f(val) - elseif (_664_ == false) then + local _737_0, _738_0, _739_0 = pcall(read) + if ((_737_0 == true) and (_738_0 == true) and (nil ~= _739_0)) then + local val = _739_0 + local _740_0, _741_0 = pcall(f, val) + if ((_740_0 == false) and (nil ~= _741_0)) then + local msg = _741_0 + return on_error("Runtime", msg) + end + elseif (_737_0 == false) then return on_error("Parse", "Couldn't parse input.") - else - return nil end end commands.reload = function(env, read, on_values, on_error) - local function _668_(_241) + local function _744_(_241) return reload(tostring(_241), env, on_values, on_error) end - return run_command(read, on_error, _668_) + return run_command(read, on_error, _744_) end do end (compiler.metadata):set(commands.reload, "fnl/docstring", "Reload the specified module.") commands.reset = function(env, _, on_values) @@ -495,281 +493,267 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) end do end (compiler.metadata):set(commands.reset, "fnl/docstring", "Erase all repl-local scope.") commands.complete = function(env, read, on_values, on_error, scope, chars) - local function _669_() - return on_values(completer(env, scope, string.char(unpack(chars)):gsub(",complete +", ""):sub(1, -2))) + local function _745_() + return on_values(completer(env, scope, table.concat(chars):gsub("^%s*,complete%s+", ""):sub(1, -2))) end - return run_command(read, on_error, _669_) + return run_command(read, on_error, _745_) end do end (compiler.metadata):set(commands.complete, "fnl/docstring", "Print all possible completions for a given input symbol.") local function apropos_2a(pattern, tbl, prefix, seen, names) for name, subtbl in pairs(tbl) do if (("string" == type(name)) and (package ~= subtbl)) then - local _670_ = type(subtbl) - if (_670_ == "function") then + local _746_0 = type(subtbl) + if (_746_0 == "function") then if ((prefix .. name)):match(pattern) then table.insert(names, (prefix .. name)) - else end - elseif (_670_ == "table") then + elseif (_746_0 == "table") then if not seen[subtbl] then - local _673_ + local _748_ do - local _672_ = seen - _672_[subtbl] = true - _673_ = _672_ + seen[subtbl] = true + _748_ = seen end - apropos_2a(pattern, subtbl, (prefix .. name:gsub("%.", "/") .. "."), _673_, names) - else + apropos_2a(pattern, subtbl, (prefix .. name:gsub("%.", "/") .. "."), _748_, names) end - else end - else end end return names end local function apropos(pattern) - local names = apropos_2a(pattern, package.loaded, "", {}, {}) - local tbl_16_auto = {} - local i_17_auto = #tbl_16_auto - for _, name in ipairs(names) do - local val_18_auto = name:gsub("^_G%.", "") - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else - end - end - return tbl_16_auto + return apropos_2a(pattern:gsub("^_G%.", ""), package.loaded, "", {}, {}) end commands.apropos = function(_env, read, on_values, on_error, _scope) - local function _678_(_241) + local function _752_(_241) return on_values(apropos(tostring(_241))) end - return run_command(read, on_error, _678_) + return run_command(read, on_error, _752_) end do end (compiler.metadata):set(commands.apropos, "fnl/docstring", "Print all functions matching a pattern in all loaded modules.") local function apropos_follow_path(path) - local paths + local paths = nil do - local tbl_16_auto = {} - local i_17_auto = #tbl_16_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ for p in path:gmatch("[^%.]+") do - local val_18_auto = p - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + local val_19_ = p + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - paths = tbl_16_auto + paths = tbl_17_ end local tgt = package.loaded for _, path0 in ipairs(paths) do if (nil == tgt) then break end - local _681_ + local _755_ do - local _680_ = path0:gsub("%/", ".") - _681_ = _680_ + local _754_0 = path0:gsub("%/", ".") + _755_ = _754_0 end - tgt = tgt[_681_] + tgt = tgt[_755_] end return tgt end local function apropos_doc(pattern) - local tbl_16_auto = {} - local i_17_auto = #tbl_16_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ for _, path in ipairs(apropos(".*")) do - local val_18_auto + local val_19_ = nil do local tgt = apropos_follow_path(path) if ("function" == type(tgt)) then - local _682_ = (compiler.metadata):get(tgt, "fnl/docstring") - if (nil ~= _682_) then - local docstr = _682_ - val_18_auto = (docstr:match(pattern) and path) + local _756_0 = (compiler.metadata):get(tgt, "fnl/docstring") + if (nil ~= _756_0) then + local docstr = _756_0 + val_19_ = (docstr:match(pattern) and path) else - val_18_auto = nil + val_19_ = nil end else - val_18_auto = nil + val_19_ = nil end end - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - return tbl_16_auto + return tbl_17_ end commands["apropos-doc"] = function(_env, read, on_values, on_error, _scope) - local function _686_(_241) + local function _760_(_241) return on_values(apropos_doc(tostring(_241))) end - return run_command(read, on_error, _686_) + return run_command(read, on_error, _760_) end do end (compiler.metadata):set(commands["apropos-doc"], "fnl/docstring", "Print all functions that match the pattern in their docs") local function apropos_show_docs(on_values, pattern) for _, path in ipairs(apropos(pattern)) do local tgt = apropos_follow_path(path) if (("function" == type(tgt)) and (compiler.metadata):get(tgt, "fnl/docstring")) then - on_values(specials.doc(tgt, path)) - on_values() - else + on_values({specials.doc(tgt, path)}) + on_values({}) end end return nil end commands["apropos-show-docs"] = function(_env, read, on_values, on_error) - local function _688_(_241) + local function _762_(_241) return apropos_show_docs(on_values, tostring(_241)) end - return run_command(read, on_error, _688_) + return run_command(read, on_error, _762_) end do end (compiler.metadata):set(commands["apropos-show-docs"], "fnl/docstring", "Print all documentations matching a pattern in function name") - local function resolve(identifier, _689_, scope) - local _arg_690_ = _689_ - local ___replLocals___ = _arg_690_["___replLocals___"] - local env = _arg_690_ - local e - local function _691_(_241, _242) - return (___replLocals___[_242] or env[_242]) - end - e = setmetatable({}, {__index = _691_}) - local _692_, _693_ = pcall(compiler["compile-string"], tostring(identifier), {scope = scope}) - if ((_692_ == true) and (nil ~= _693_)) then - local code = _693_ - return specials["load-code"](code, e)() - else - return nil + local function resolve(identifier, _763_0, scope) + local _764_ = _763_0 + local env = _764_ + local ___replLocals___ = _764_["___replLocals___"] + local e = nil + local function _765_(_241, _242) + return (___replLocals___[scope.unmanglings[_242]] or env[_242]) + end + e = setmetatable({}, {__index = _765_}) + local function _766_(...) + local _767_0, _768_0 = ... + if ((_767_0 == true) and (nil ~= _768_0)) then + local code = _768_0 + local function _769_(...) + local _770_0, _771_0 = ... + if ((_770_0 == true) and (nil ~= _771_0)) then + local val = _771_0 + return val + else + local _ = _770_0 + return nil + end + end + return _769_(pcall(specials["load-code"](code, e))) + else + local _ = _767_0 + return nil + end end + return _766_(pcall(compiler["compile-string"], tostring(identifier), {scope = scope})) end commands.find = function(env, read, on_values, on_error, scope) - local function _695_(_241) - local _696_ + local function _774_(_241) + local _775_0 = nil do - local _697_ = utils["sym?"](_241) - if (nil ~= _697_) then - local _698_ = resolve(_697_, env, scope) - if (nil ~= _698_) then - _696_ = debug.getinfo(_698_) + local _776_0 = utils["sym?"](_241) + if (nil ~= _776_0) then + local _777_0 = resolve(_776_0, env, scope) + if (nil ~= _777_0) then + _775_0 = debug.getinfo(_777_0) else - _696_ = _698_ + _775_0 = _777_0 end else - _696_ = _697_ + _775_0 = _776_0 end end - if ((_G.type(_696_) == "table") and ((_696_).what == "Lua") and (nil ~= (_696_).source) and (nil ~= (_696_).linedefined) and (nil ~= (_696_).short_src)) then - local source = (_696_).source - local line = (_696_).linedefined - local src = (_696_).short_src - local fnlsrc + if ((_G.type(_775_0) == "table") and (nil ~= _775_0.linedefined) and (nil ~= _775_0.short_src) and (nil ~= _775_0.source) and (_775_0.what == "Lua")) then + local line = _775_0.linedefined + local src = _775_0.short_src + local source = _775_0.source + local fnlsrc = nil do - local t_701_ = compiler.sourcemap - if (nil ~= t_701_) then - t_701_ = (t_701_)[source] - else + local _780_0 = compiler.sourcemap + if (nil ~= _780_0) then + _780_0 = _780_0[source] end - if (nil ~= t_701_) then - t_701_ = (t_701_)[line] - else + if (nil ~= _780_0) then + _780_0 = _780_0[line] end - if (nil ~= t_701_) then - t_701_ = (t_701_)[2] - else + if (nil ~= _780_0) then + _780_0 = _780_0[2] end - fnlsrc = t_701_ + fnlsrc = _780_0 end return on_values({string.format("%s:%s", src, (fnlsrc or line))}) - elseif (_696_ == nil) then + elseif (_775_0 == nil) then return on_error("Repl", "Unknown value") - elseif true then - local _ = _696_ - return on_error("Repl", "No source info") else - return nil + local _ = _775_0 + return on_error("Repl", "No source info") end end - return run_command(read, on_error, _695_) + return run_command(read, on_error, _774_) end do end (compiler.metadata):set(commands.find, "fnl/docstring", "Print the filename and line number for a given function") commands.doc = function(env, read, on_values, on_error, scope) - local function _706_(_241) + local function _785_(_241) local name = tostring(_241) local path = (utils["multi-sym?"](name) or {name}) local ok_3f, target = nil, nil - local function _707_() - return (utils["get-in"](scope.specials, path) or utils["get-in"](scope.macros, path) or resolve(name, env, scope)) + local function _786_() + return (scope.specials[name] or utils["get-in"](scope.macros, path) or resolve(name, env, scope)) end - ok_3f, target = pcall(_707_) + ok_3f, target = pcall(_786_) if ok_3f then return on_values({specials.doc(target, name)}) else - return on_error("Repl", "Could not resolve value for docstring lookup") + return on_error("Repl", ("Could not find " .. name .. " for docs.")) end end - return run_command(read, on_error, _706_) + return run_command(read, on_error, _785_) end do end (compiler.metadata):set(commands.doc, "fnl/docstring", "Print the docstring and arglist for a function, macro, or special form.") - commands.compile = function(env, read, on_values, on_error, scope) - local function _709_(_241) - local allowedGlobals = specials["current-global-names"](env) - local ok_3f, result = pcall(compiler.compile, _241, {env = env, scope = scope, allowedGlobals = allowedGlobals}) - if ok_3f then + commands.compile = function(_, read, on_values, on_error, _0, _1, opts) + local function _788_(_241) + local _789_0, _790_0 = pcall(compiler.compile, _241, opts) + if ((_789_0 == true) and (nil ~= _790_0)) then + local result = _790_0 return on_values({result}) - else - return on_error("Repl", ("Error compiling expression: " .. result)) + elseif (true and (nil ~= _790_0)) then + local _2 = _789_0 + local msg = _790_0 + return on_error("Repl", ("Error compiling expression: " .. msg)) end end - return run_command(read, on_error, _709_) + return run_command(read, on_error, _788_) end do end (compiler.metadata):set(commands.compile, "fnl/docstring", "compiles the expression into lua and prints the result.") local function load_plugin_commands(plugins) - for _, plugin in ipairs((plugins or {})) do - for name, f in pairs(plugin) do - local _711_ = name:match("^repl%-command%-(.*)") - if (nil ~= _711_) then - local cmd_name = _711_ - commands[cmd_name] = (commands[cmd_name] or f) - else + for i = #(plugins or {}), 1, -1 do + for name, f in pairs(plugins[i]) do + local _792_0 = name:match("^repl%-command%-(.*)") + if (nil ~= _792_0) then + local cmd_name = _792_0 + commands[cmd_name] = f end end end return nil end - local function run_command_loop(input, read, loop, env, on_values, on_error, scope, chars) + local function run_command_loop(input, read, loop, env, on_values, on_error, scope, chars, opts) local command_name = input:match(",([^%s/]+)") do - local _713_ = commands[command_name] - if (nil ~= _713_) then - local command = _713_ - command(env, read, on_values, on_error, scope, chars) - elseif true then - local _ = _713_ - if ("exit" ~= command_name) then + local _794_0 = commands[command_name] + if (nil ~= _794_0) then + local command = _794_0 + command(env, read, on_values, on_error, scope, chars, opts) + else + local _ = _794_0 + if ((command_name ~= "exit") and (command_name ~= "return")) then on_values({"Unknown command", command_name}) - else end - else end end if ("exit" ~= command_name) then - return loop() - else - return nil + return loop((command_name == "return")) end end local function try_readline_21(opts, ok, readline) if ok then if readline.set_readline_name then readline.set_readline_name("fennel") - else end - readline.set_options({keeplines = 1000, histfile = ""}) + readline.set_options({histfile = "", keeplines = 1000}) opts.readChunk = function(parser_state) - local prompt + local prompt = nil if (0 < parser_state["stack-size"]) then prompt = ".. " else @@ -778,8 +762,6 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) local str = readline.readline(prompt) if str then return (str .. "\n") - else - return nil end end local completer0 = nil @@ -790,15 +772,13 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) local function repl_completer(text, from, to) if completer0 then readline.set_completion_append_character("") - return completer0(text:sub(from, to)) + return completer0(text:sub(from, to), text, from, to) else return {} end end readline.set_complete_function(repl_completer) return readline - else - return nil end end local function should_use_readline_3f(opts) @@ -806,148 +786,170 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) end local function repl(_3foptions) local old_root_options = utils.root.options - local _let_722_ = utils.copy(_3foptions) - local _3ffennelrc = _let_722_["fennelrc"] - local opts = _let_722_ - local _ + local _803_ = utils.copy(_3foptions) + local opts = _803_ + local _3ffennelrc = _803_["fennelrc"] + local _ = nil opts.fennelrc = nil _ = nil local readline = (should_use_readline_3f(opts) and try_readline_21(opts, pcall(require, "readline"))) - local _0 + local _0 = nil if _3ffennelrc then _0 = _3ffennelrc() else - _0 = nil + _0 = nil end local env = specials["wrap-env"]((opts.env or rawget(_G, "_ENV") or _G)) + local callbacks = {["view-opts"] = (opts["view-opts"] or {depth = 4}), env = env, onError = (opts.onError or default_on_error), onValues = (opts.onValues or default_on_values), pp = (opts.pp or view), readChunk = (opts.readChunk or default_read_chunk)} local save_locals_3f = (opts.saveLocals ~= false) - local read_chunk = (opts.readChunk or default_read_chunk) - local on_values = (opts.onValues or default_on_values) - local on_error = (opts.onError or default_on_error) - local pp = (opts.pp or view) - local byte_stream, clear_stream = parser.granulate(read_chunk) + local byte_stream, clear_stream = nil, nil + local function _805_(_241) + return callbacks.readChunk(_241) + end + byte_stream, clear_stream = parser.granulate(_805_) local chars = {} local read, reset = nil, nil - local function _724_(parser_state) - local c = byte_stream(parser_state) - table.insert(chars, c) - return c + local function _806_(parser_state) + local b = byte_stream(parser_state) + if b then + table.insert(chars, string.char(b)) + end + return b end - read, reset = parser.parser(_724_) + read, reset = parser.parser(_806_) + depth = (depth + 1) + if opts.message then + callbacks.onValues({opts.message}) + end + env.___repl___ = callbacks opts.env, opts.scope = env, compiler["make-scope"]() opts.useMetadata = (opts.useMetadata ~= false) if (opts.allowedGlobals == nil) then opts.allowedGlobals = specials["current-global-names"](env) - else + end + if opts.init then + opts.init(opts, depth) end if opts.registerCompleter then - local function _728_() - local _726_ = env - local _727_ = opts.scope - local function _729_(...) - return completer(_726_, _727_, ...) + local function _812_() + local _811_0 = opts.scope + local function _813_(...) + return completer(env, _811_0, ...) end - return _729_ + return _813_ end - opts.registerCompleter(_728_()) - else + opts.registerCompleter(_812_()) end load_plugin_commands(opts.plugins) if save_locals_3f then local function newindex(t, k, v) - if opts.scope.unmanglings[k] then + if opts.scope.manglings[k] then return rawset(t, k, v) - else - return nil end end env.___replLocals___ = setmetatable({}, {__newindex = newindex}) - else end local function print_values(...) local vals = {...} local out = {} + local pp = callbacks.pp env._, env.__ = vals[1], vals for i = 1, select("#", ...) do - table.insert(out, pp(vals[i])) + table.insert(out, pp(vals[i], callbacks["view-opts"])) end - return on_values(out) + return callbacks.onValues(out) + end + local function save_value(...) + env.___replLocals___["*3"] = env.___replLocals___["*2"] + env.___replLocals___["*2"] = env.___replLocals___["*1"] + env.___replLocals___["*1"] = ... + return ... end - local function loop() + opts.scope.manglings["*1"], opts.scope.unmanglings._1 = "_1", "*1" + opts.scope.manglings["*2"], opts.scope.unmanglings._2 = "_2", "*2" + opts.scope.manglings["*3"], opts.scope.unmanglings._3 = "_3", "*3" + local function loop(exit_next_3f) for k in pairs(chars) do chars[k] = nil end reset() - local ok, parser_not_eof_3f, x = pcall(read) - local src_string = string.char(unpack(chars)) + local ok, parser_not_eof_3f, form = pcall(read) + local src_string = table.concat(chars) local readline_not_eof_3f = (not readline or (src_string ~= "(null)")) local not_eof_3f = (readline_not_eof_3f and parser_not_eof_3f) if not ok then - on_error("Parse", not_eof_3f) + callbacks.onError("Parse", not_eof_3f) clear_stream() return loop() elseif command_3f(src_string) then - return run_command_loop(src_string, read, loop, env, on_values, on_error, opts.scope, chars) + return run_command_loop(src_string, read, loop, env, callbacks.onValues, callbacks.onError, opts.scope, chars, opts) else if not_eof_3f then - do - local _733_, _734_ = nil, nil - local function _736_() - local _735_ = opts - _735_["source"] = src_string - return _735_ - end - _733_, _734_ = pcall(compiler.compile, x, _736_()) - if ((_733_ == false) and (nil ~= _734_)) then - local msg = _734_ - clear_stream() - on_error("Compile", msg) - elseif ((_733_ == true) and (nil ~= _734_)) then - local src = _734_ - local src0 - if save_locals_3f then - src0 = splice_save_locals(env, src, opts.scope) - else - src0 = src - end - local _738_, _739_ = pcall(specials["load-code"], src0, env) - if ((_738_ == false) and (nil ~= _739_)) then - local msg = _739_ - clear_stream() - on_error("Lua Compile", msg, src0) - elseif (true and (nil ~= _739_)) then - local _1 = _738_ - local chunk = _739_ - local function _740_() - return print_values(chunk()) - end - local function _741_() - local function _742_(...) - return on_error("Runtime", ...) + local function _817_(...) + local _818_0, _819_0 = ... + if ((_818_0 == true) and (nil ~= _819_0)) then + local src = _819_0 + local function _820_(...) + local _821_0, _822_0 = ... + if ((_821_0 == true) and (nil ~= _822_0)) then + local chunk = _822_0 + local function _823_() + return print_values(save_value(chunk())) end - return _742_ + local function _824_(...) + return callbacks.onError("Runtime", ...) + end + return xpcall(_823_, _824_) + elseif ((_821_0 == false) and (nil ~= _822_0)) then + local msg = _822_0 + clear_stream() + return callbacks.onError("Compile", msg) end - xpcall(_740_, _741_()) - else end - else + local function _827_(...) + local src0 = nil + if save_locals_3f then + src0 = splice_save_locals(env, src, opts.scope) + else + src0 = src + end + return pcall(specials["load-code"], src0, env) + end + return _820_(_827_(...)) + elseif ((_818_0 == false) and (nil ~= _819_0)) then + local msg = _819_0 + clear_stream() + return callbacks.onError("Compile", msg) end end + local function _829_() + opts["source"] = src_string + return opts + end + _817_(pcall(compiler.compile, form, _829_())) utils.root.options = old_root_options - return loop() - else - return nil + if exit_next_3f then + return env.___replLocals___["*1"] + else + return loop() + end end end end - loop() + local value = loop() + depth = (depth - 1) if readline then - return readline.save_history() - else - return nil + readline.save_history() + end + if opts.exit then + opts.exit(opts, depth) end + return value end - return repl + local function _835_(overrides, _3fopts) + return repl(utils.copy(_3fopts, utils.copy(overrides))) + end + return setmetatable({}, {__call = _835_, __index = {repl = repl}}) end package.preload["fennel.specials"] = package.preload["fennel.specials"] or function(...) local utils = require("fennel.utils") @@ -956,15 +958,18 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local compiler = require("fennel.compiler") local unpack = (table.unpack or _G.unpack) local SPECIALS = compiler.scopes.global.specials + local function str1(x) + return tostring(x[1]) + end local function wrap_env(env) - local function _424_(_, key) + local function _475_(_, key) if utils["string?"](key) then return env[compiler["global-unmangling"](key)] else return env[key] end end - local function _426_(_, key, value) + local function _477_(_, key, value) if utils["string?"](key) then env[compiler["global-unmangling"](key)] = value return nil @@ -973,82 +978,105 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return nil end end - local function _428_() - local function putenv(k, v) - local _429_ - if utils["string?"](k) then - _429_ = compiler["global-unmangling"](k) - else - _429_ = k + local function _479_() + local _480_ + do + local tbl_14_ = {} + for k, v in utils.stablepairs(env) do + local k_15_, v_16_ = nil, nil + local _481_ + if utils["string?"](k) then + _481_ = compiler["global-unmangling"](k) + else + _481_ = k + end + k_15_, v_16_ = _481_, v + if ((k_15_ ~= nil) and (v_16_ ~= nil)) then + tbl_14_[k_15_] = v_16_ + end end - return _429_, v + _480_ = tbl_14_ end - return next, utils.kvmap(env, putenv), nil + return next, _480_, nil end - return setmetatable({}, {__index = _424_, __newindex = _426_, __pairs = _428_}) + return setmetatable({}, {__index = _475_, __newindex = _477_, __pairs = _479_}) + end + local function fennel_module_name() + return (utils.root.options.moduleName or "fennel") end local function current_global_names(_3fenv) - local mt + local mt = nil do - local _431_ = getmetatable(_3fenv) - if ((_G.type(_431_) == "table") and (nil ~= (_431_).__pairs)) then - local mtpairs = (_431_).__pairs - local tbl_13_auto = {} + local _484_0 = getmetatable(_3fenv) + if ((_G.type(_484_0) == "table") and (nil ~= _484_0.__pairs)) then + local mtpairs = _484_0.__pairs + local tbl_14_ = {} for k, v in mtpairs(_3fenv) do - local k_14_auto, v_15_auto = k, v - if ((k_14_auto ~= nil) and (v_15_auto ~= nil)) then - tbl_13_auto[k_14_auto] = v_15_auto - else + local k_15_, v_16_ = k, v + if ((k_15_ ~= nil) and (v_16_ ~= nil)) then + tbl_14_[k_15_] = v_16_ end end - mt = tbl_13_auto - elseif (_431_ == nil) then + mt = tbl_14_ + elseif (_484_0 == nil) then mt = (_3fenv or _G) else - mt = nil + mt = nil + end + end + local function _487_() + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for k in utils.stablepairs(mt) do + local val_19_ = compiler["global-unmangling"](k) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end end + return tbl_17_ end - return (mt and utils.kvmap(mt, compiler["global-unmangling"])) + return (mt and _487_()) end local function load_code(code, _3fenv, _3ffilename) local env = (_3fenv or rawget(_G, "_ENV") or _G) - local _434_, _435_ = rawget(_G, "setfenv"), rawget(_G, "loadstring") - if ((nil ~= _434_) and (nil ~= _435_)) then - local setfenv = _434_ - local loadstring = _435_ + local _489_0, _490_0 = rawget(_G, "setfenv"), rawget(_G, "loadstring") + if ((nil ~= _489_0) and (nil ~= _490_0)) then + local setfenv = _489_0 + local loadstring = _490_0 local f = assert(loadstring(code, _3ffilename)) - local _436_ = f - setfenv(_436_, env) - return _436_ - elseif true then - local _ = _434_ - return assert(load(code, _3ffilename, "t", env)) + setfenv(f, env) + return f else - return nil + local _ = _489_0 + return assert(load(code, _3ffilename, "t", env)) end end + local function v__3edocstring(tgt) + return (((compiler.metadata):get(tgt, "fnl/docstring") or "#")):gsub("\n$", ""):gsub("\n", "\n ") + end local function doc_2a(tgt, name) + assert(("string" == type(name)), "name must be a string") if not tgt then return (name .. " not found") else - local docstring = (((compiler.metadata):get(tgt, "fnl/docstring") or "#")):gsub("\n$", ""):gsub("\n", "\n ") - local mt = getmetatable(tgt) - if ((type(tgt) == "function") or ((type(mt) == "table") and (type(mt.__call) == "function"))) then - local arglist = table.concat(((compiler.metadata):get(tgt, "fnl/arglist") or {"#"}), " ") - local _438_ - if (0 < #arglist) then - _438_ = " " - else - _438_ = "" + local function _493_() + local _492_0 = getmetatable(tgt) + if ((_G.type(_492_0) == "table") and true) then + local __call = _492_0.__call + return ("function" == type(__call)) end - return string.format("(%s%s%s)\n %s", name, _438_, arglist, docstring) + end + if ((type(tgt) == "function") or _493_()) then + local elts = {name, unpack(((compiler.metadata):get(tgt, "fnl/arglist") or {"#"}))} + return string.format("(%s)\n %s", table.concat(elts, " "), v__3edocstring(tgt)) else - return string.format("%s\n %s", name, docstring) + return string.format("%s\n %s", name, v__3edocstring(tgt)) end end end local function doc_special(name, arglist, docstring, body_form_3f) - compiler.metadata[SPECIALS[name]] = {["fnl/arglist"] = arglist, ["fnl/docstring"] = docstring, ["fnl/body-form?"] = body_form_3f} + compiler.metadata[SPECIALS[name]] = {["fnl/arglist"] = arglist, ["fnl/body-form?"] = body_form_3f, ["fnl/docstring"] = docstring} return nil end local function compile_do(ast, scope, parent, _3fstart) @@ -1066,18 +1094,14 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local chunk = (_3fchunk or {}) local len = #ast local retexprs = {returned = true} + utils.hook("pre-do", ast, sub_scope) local function compile_body(outer_target, outer_tail, outer_retexprs) - if (len < start) then - compiler.compile1(nil, sub_scope, chunk, {tail = outer_tail, target = outer_target}) - else - for i = start, len do - local subopts = {nval = (((i ~= len) and 0) or opts.nval), tail = (((i == len) and outer_tail) or nil), target = (((i == len) and outer_target) or nil)} - local _ = utils["propagate-options"](opts, subopts) - local subexprs = compiler.compile1(ast[i], sub_scope, chunk, subopts) - if (i ~= len) then - compiler["keep-side-effects"](subexprs, parent, nil, ast[i]) - else - end + for i = start, len do + local subopts = {nval = (((i ~= len) and 0) or opts.nval), tail = (((i == len) and outer_tail) or nil), target = (((i == len) and outer_target) or nil)} + local _ = utils["propagate-options"](opts, subopts) + local subexprs = compiler.compile1(ast[i], sub_scope, chunk, subopts) + if (i ~= len) then + compiler["keep-side-effects"](subexprs, parent, nil, ast[i]) end end compiler.emit(parent, chunk, ast) @@ -1091,8 +1115,8 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct elseif opts.nval then local syms = {} for i = 1, opts.nval do - local s = ((_3fpre_syms and (_3fpre_syms)[i]) or compiler.gensym(scope)) - do end (syms)[i] = s + local s = ((_3fpre_syms and _3fpre_syms[i]) or compiler.gensym(scope)) + syms[i] = s retexprs[i] = utils.expr(s, "sym") end local outer_target = table.concat(syms, ", ") @@ -1101,7 +1125,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return compile_body(outer_target, opts.tail) else local fname = compiler.gensym(scope) - local fargs + local fargs = nil if scope.vararg then fargs = "..." else @@ -1112,17 +1136,28 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end end doc_special("do", {"..."}, "Evaluate multiple forms; return last value.", true) + local function iter_args(ast) + local ast0, len, i = ast, #ast, 1 + local function _499_() + i = (1 + i) + while ((i == len) and utils["call-of?"](ast0[i], "values")) do + ast0 = ast0[i] + len = #ast0 + i = 2 + end + return ast0[i], (nil == ast0[(i + 1)]) + end + return _499_ + end SPECIALS.values = function(ast, scope, parent) - local len = #ast local exprs = {} - for i = 2, len do - local subexprs = compiler.compile1(ast[i], scope, parent, {nval = ((i ~= len) and 1)}) + for subast, last_3f in iter_args(ast) do + local subexprs = compiler.compile1(subast, scope, parent, {nval = (not last_3f and 1)}) table.insert(exprs, subexprs[1]) - if (i == len) then + if last_3f then for j = 2, #subexprs do table.insert(exprs, subexprs[j]) end - else end end return exprs @@ -1130,9 +1165,8 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct doc_special("values", {"..."}, "Return multiple values from a function. Must be in tail position.") local function __3estack(stack, tbl) for k, v in pairs(tbl) do - local _447_ = stack - table.insert(_447_, k) - table.insert(_447_, v) + table.insert(stack, k) + table.insert(stack, v) end return stack end @@ -1148,10 +1182,8 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct res = false elseif utils["table?"](elt) then __3estack(stack, elt) - else end end - else end return res end @@ -1159,36 +1191,44 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local opts = {nval = 1, tail = false} local scope = compiler["make-scope"]() local chunk = {} - local _let_450_ = compiler.compile1(v, scope, chunk, opts) - local _let_451_ = _let_450_[1] - local v0 = _let_451_[1] + local _503_ = compiler.compile1(v, scope, chunk, opts) + local _504_ = _503_[1] + local v0 = _504_[1] return v0 end local function insert_meta(meta, k, v) local view_opts = {["escape-newlines?"] = true, ["line-length"] = math.huge, ["one-line?"] = true} compiler.assert((type(k) == "string"), ("expected string keys in metadata table, got: %s"):format(view(k, view_opts))) compiler.assert(literal_3f(v), ("expected literal value in metadata table, got: %s %s"):format(view(k, view_opts), view(v, view_opts))) - local _452_ = meta - table.insert(_452_, view(k)) - local function _453_() + table.insert(meta, view(k)) + local function _505_() if ("string" == type(v)) then return view(v, view_opts) else return compile_value(v) end end - table.insert(_452_, _453_()) - return _452_ + table.insert(meta, _505_()) + return meta end local function insert_arglist(meta, arg_list) - local view_opts = {["one-line?"] = true, ["escape-newlines?"] = true, ["line-length"] = math.huge} - local _454_ = meta - table.insert(_454_, "\"fnl/arglist\"") - local function _455_(_241) - return view(view(_241, view_opts)) + local opts = {["escape-newlines?"] = true, ["line-length"] = math.huge, ["one-line?"] = true} + local view_args = nil + do + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for _, arg in ipairs(arg_list) do + local val_19_ = view(view(arg, opts)) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end + end + view_args = tbl_17_ end - table.insert(_454_, ("{" .. table.concat(utils.map(arg_list, _455_), ", ") .. "}")) - return _454_ + table.insert(meta, "\"fnl/arglist\"") + table.insert(meta, ("{" .. table.concat(view_args, ", ") .. "}")) + return meta end local function set_fn_metadata(f_metadata, parent, fn_name) if utils.root.options.useMetadata then @@ -1200,36 +1240,35 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct insert_meta(meta_fields, k, v) end end - local meta_str = ("require(\"%s\").metadata"):format((utils.root.options.moduleName or "fennel")) + local meta_str = ("require(\"%s\").metadata"):format(fennel_module_name()) return compiler.emit(parent, ("pcall(function() %s:setall(%s, %s) end)"):format(meta_str, fn_name, table.concat(meta_fields, ", "))) - else - return nil end end local function get_fn_name(ast, scope, fn_name, multi) if (fn_name and (fn_name[1] ~= "nil")) then - local _458_ + local _509_ if not multi then - _458_ = compiler["declare-local"](fn_name, {}, scope, ast) + _509_ = compiler["declare-local"](fn_name, scope, ast) else - _458_ = (compiler["symbol-to-expression"](fn_name, scope))[1] + _509_ = compiler["symbol-to-expression"](fn_name, scope)[1] end - return _458_, not multi, 3 + return _509_, not multi, 3 else 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, f_metadata) + utils.hook("pre-fn", ast, f_scope) 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 _461_ + local _512_ if local_3f then - _461_ = "local function %s(%s)" + _512_ = "local function %s(%s)" else - _461_ = "%s = function(%s)" + _512_ = "%s = function(%s)" end - compiler.emit(parent, string.format(_461_, fn_name, table.concat(arg_name_list, ", ")), ast) + compiler.emit(parent, string.format(_512_, fn_name, table.concat(arg_name_list, ", ")), ast) compiler.emit(parent, f_chunk, ast) compiler.emit(parent, "end", ast) set_fn_metadata(f_metadata, parent, fn_name) @@ -1240,64 +1279,52 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local fn_name = compiler.gensym(scope) return compile_named_fn(ast, f_scope, f_chunk, parent, index, fn_name, true, arg_name_list, f_metadata) end - local function assoc_table_3f(t) - local len = #t - local nxt, t0, k = pairs(t) - local function _463_() - if (len == 0) then - return k - else - return len - end + local function maybe_metadata(ast, pred, handler, mt, index) + local index_2a = (index + 1) + local index_2a_before_ast_end_3f = (index_2a < #ast) + local expr = ast[index_2a] + if (index_2a_before_ast_end_3f and pred(expr)) then + return handler(mt, expr), index_2a + else + return mt, index end - return (nil ~= nxt(t0, _463_())) end local function get_function_metadata(ast, arg_list, index) - local f_metadata = {["fnl/arglist"] = arg_list} - local index_2a = (index + 1) - local expr = ast[index_2a] - if (utils["string?"](expr) and (index_2a < #ast)) then - local _465_ - do - local _464_ = f_metadata - _464_["fnl/docstring"] = expr - _465_ = _464_ - end - return _465_, index_2a - elseif (utils["table?"](expr) and (index_2a < #ast) and assoc_table_3f(expr)) then - local _466_ - do - local tbl_13_auto = f_metadata - for k, v in pairs(expr) do - local k_14_auto, v_15_auto = k, v - if ((k_14_auto ~= nil) and (v_15_auto ~= nil)) then - tbl_13_auto[k_14_auto] = v_15_auto - else - end + local function _515_(_241, _242) + local tbl_14_ = _241 + for k, v in pairs(_242) do + local k_15_, v_16_ = k, v + if ((k_15_ ~= nil) and (v_16_ ~= nil)) then + tbl_14_[k_15_] = v_16_ end - _466_ = tbl_13_auto end - return _466_, index_2a - else - return f_metadata, index + return tbl_14_ + end + local function _517_(_241, _242) + _241["fnl/docstring"] = _242 + return _241 end + return maybe_metadata(ast, utils["kv-table?"], _515_, maybe_metadata(ast, utils["string?"], _517_, {["fnl/arglist"] = arg_list}, index)) end - SPECIALS.fn = function(ast, scope, parent) - local f_scope + SPECIALS.fn = function(ast, scope, parent, opts) + local f_scope = nil do - local _469_ = compiler["make-scope"](scope) - do end (_469_)["vararg"] = false - f_scope = _469_ + local _518_0 = compiler["make-scope"](scope) + _518_0["vararg"] = false + f_scope = _518_0 end 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_3f, index = get_fn_name(ast, scope, fn_sym, multi) + local fn_name, local_3f, index = get_fn_name(ast, scope, fn_sym, multi, opts) 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) + if (multi and not scope.symmeta[multi[1]] and not compiler["global-allowed?"](multi[1])) then + compiler.assert(nil, ("expected local table " .. multi[1]), ast[2]) + end local function destructure_arg(arg) local raw = utils.sym(compiler.gensym(scope)) - local declared = compiler["declare-local"](raw, {}, f_scope, ast) + local declared = compiler["declare-local"](raw, f_scope, ast) compiler.destructure(arg, raw, ast, f_scope, f_chunk, {declaration = true, nomulti = true, symtype = "arg"}) return declared end @@ -1314,29 +1341,28 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct compiler.assert((arg == arg_list[#arg_list]), "expected vararg as last parameter", ast) f_scope.vararg = true return "..." - elseif (utils.sym("&") == arg) then + elseif utils["sym?"](arg, "&") then return destructure_amp(i) elseif (utils["sym?"](arg) and (tostring(arg) ~= "nil") and not utils["multi-sym?"](tostring(arg))) then - return compiler["declare-local"](arg, {}, f_scope, ast) + return compiler["declare-local"](arg, f_scope, ast) elseif utils["table?"](arg) then return destructure_arg(arg) else return compiler.assert(false, ("expected symbol for function parameter: %s"):format(tostring(arg)), ast[index]) end end - local arg_name_list + local arg_name_list = nil do - local tbl_16_auto = {} - local i_17_auto = #tbl_16_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ for i, a in ipairs(arg_list) do - local val_18_auto = get_arg_name(a, i) - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + local val_19_ = get_arg_name(a, i) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - arg_name_list = tbl_16_auto + arg_name_list = tbl_17_ end local f_metadata, index0 = get_function_metadata(ast, arg_list, index) if fn_name then @@ -1348,39 +1374,37 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct doc_special("fn", {"name?", "args", "docstring?", "..."}, "Function syntax. May optionally include a name and docstring or a metadata table.\nIf a name is provided, the function will be bound in the current scope.\nWhen called with the wrong number of args, excess args will be discarded\nand lacking args will be nil, use lambda for arity-checked functions.", true) SPECIALS.lua = function(ast, _, parent) compiler.assert(((#ast == 2) or (#ast == 3)), "expected 1 or 2 arguments", ast) - local _474_ + local _524_ do - local _473_ = utils["sym?"](ast[2]) - if (nil ~= _473_) then - _474_ = tostring(_473_) + local _523_0 = utils["sym?"](ast[2]) + if (nil ~= _523_0) then + _524_ = tostring(_523_0) else - _474_ = _473_ + _524_ = _523_0 end end - if ("nil" ~= _474_) then + if ("nil" ~= _524_) then table.insert(parent, {ast = ast, leaf = tostring(ast[2])}) - else end - local _478_ + local _528_ do - local _477_ = utils["sym?"](ast[3]) - if (nil ~= _477_) then - _478_ = tostring(_477_) + local _527_0 = utils["sym?"](ast[3]) + if (nil ~= _527_0) then + _528_ = tostring(_527_0) else - _478_ = _477_ + _528_ = _527_0 end end - if ("nil" ~= _478_) then + if ("nil" ~= _528_) then return tostring(ast[3]) - else - return nil end end local function dot(ast, scope, parent) compiler.assert((1 < #ast), "expected table argument", ast) local len = #ast - local _let_481_ = compiler.compile1(ast[2], scope, parent, {nval = 1}) - local lhs = _let_481_[1] + local lhs_node = compiler.macroexpand(ast[2], scope) + local _531_ = compiler.compile1(lhs_node, scope, parent, {nval = 1}) + local lhs = _531_[1] if (len == 2) then return tostring(lhs) else @@ -1390,12 +1414,12 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct if (utils["string?"](index) and utils["valid-lua-identifier?"](index)) then table.insert(indices, ("." .. index)) else - local _let_482_ = compiler.compile1(index, scope, parent, {nval = 1}) - local index0 = _let_482_[1] + local _532_ = compiler.compile1(index, scope, parent, {nval = 1}) + local index0 = _532_[1] table.insert(indices, ("[" .. tostring(index0) .. "]")) end end - if (tostring(lhs):find("[{\"0-9]") or ("nil" == tostring(lhs))) then + if (not (utils["sym?"](lhs_node) or utils["list?"](lhs_node)) or ("nil" == tostring(lhs_node))) then return ("(" .. tostring(lhs) .. ")" .. table.concat(indices)) else return (tostring(lhs) .. table.concat(indices)) @@ -1409,7 +1433,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct compiler.destructure(ast[2], ast[3], ast, scope, parent, {forceglobal = true, nomulti = true, symtype = "global"}) return nil end - doc_special("global", {"name", "val"}, "Set name as a global with val.") + doc_special("global", {"name", "val"}, "Set name as a global with val. Deprecated.") SPECIALS.set = function(ast, scope, parent) compiler.assert((#ast == 3), "expected name and value", ast) compiler.destructure(ast[2], ast[3], ast, scope, parent, {noundef = true, symtype = "set"}) @@ -1422,49 +1446,62 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return nil end SPECIALS["set-forcibly!"] = set_forcibly_21_2a - local function local_2a(ast, scope, parent) + local function local_2a(ast, scope, parent, opts) + compiler.assert(((0 == opts.nval) or opts.tail), "can't introduce local here", ast) compiler.assert((#ast == 3), "expected name and value", ast) compiler.destructure(ast[2], ast[3], ast, scope, parent, {declaration = true, nomulti = true, symtype = "local"}) return nil end SPECIALS["local"] = local_2a doc_special("local", {"name", "val"}, "Introduce new top-level immutable local.") - SPECIALS.var = function(ast, scope, parent) + SPECIALS.var = function(ast, scope, parent, opts) + compiler.assert(((0 == opts.nval) or opts.tail), "can't introduce var here", ast) compiler.assert((#ast == 3), "expected name and value", ast) compiler.destructure(ast[2], ast[3], ast, scope, parent, {declaration = true, isvar = true, nomulti = true, symtype = "var"}) return nil end doc_special("var", {"name", "val"}, "Introduce new mutable local.") local function kv_3f(t) - local _486_ + local _536_ do - local tbl_16_auto = {} - local i_17_auto = #tbl_16_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ for k in pairs(t) do - local val_18_auto + local val_19_ = nil if ("number" ~= type(k)) then - val_18_auto = k + val_19_ = k else - val_18_auto = nil + val_19_ = nil end - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - _486_ = tbl_16_auto + _536_ = tbl_17_ end - return (_486_)[1] + return _536_[1] end - SPECIALS.let = function(ast, scope, parent, opts) - local bindings = ast[2] - local pre_syms = {} - compiler.assert((utils["table?"](bindings) and not kv_3f(bindings)), "expected binding sequence", bindings) - compiler.assert(((#bindings % 2) == 0), "expected even number of name/value bindings", ast[2]) + SPECIALS.let = function(_539_0, scope, parent, opts) + local _540_ = _539_0 + local _ = _540_[1] + local bindings = _540_[2] + local ast = _540_ + compiler.assert((utils["table?"](bindings) and not kv_3f(bindings)), "expected binding sequence", (bindings or ast[1])) + compiler.assert(((#bindings % 2) == 0), "expected even number of name/value bindings", bindings) compiler.assert((3 <= #ast), "expected body expression", ast[1]) - for _ = 1, (opts.nval or 0) do - table.insert(pre_syms, compiler.gensym(scope)) + local pre_syms = nil + do + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for _0 = 1, (opts.nval or 0) do + local val_19_ = compiler.gensym(scope) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end + end + pre_syms = tbl_17_ end local sub_scope = compiler["make-scope"](scope) local sub_chunk = {} @@ -1481,39 +1518,43 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return (parent or "") end end - local function disambiguate_3f(rootstr, parent) - local function _491_() - local _490_ = get_prev_line(parent) - if (nil ~= _490_) then - local prev_line = _490_ - return prev_line:match("%)$") - else - return nil - end - end - return (rootstr:match("^{") or _491_()) + local function needs_separator_3f(root, prev_line) + return (root:match("^%(") and prev_line and not prev_line:find(" end$")) end SPECIALS.tset = function(ast, scope, parent) compiler.assert((3 < #ast), "expected table, key, and value arguments", ast) - local root = (compiler.compile1(ast[2], scope, parent, {nval = 1}))[1] - local keys = {} - for i = 3, (#ast - 1) do - local _let_493_ = compiler.compile1(ast[i], scope, parent, {nval = 1}) - local key = _let_493_[1] - table.insert(keys, tostring(key)) - end - local value = (compiler.compile1(ast[#ast], scope, parent, {nval = 1}))[1] - local rootstr = tostring(root) - local fmtstr - if disambiguate_3f(rootstr, parent) then - fmtstr = "do end (%s)[%s] = %s" + compiler.assert(((type(ast[2]) ~= "boolean") and (type(ast[2]) ~= "number")), "cannot set field of literal value", ast) + local root = str1(compiler.compile1(ast[2], scope, parent, {nval = 1})) + local root0 = nil + if root:match("^[.{\"]") then + root0 = string.format("(%s)", root) + else + root0 = root + end + local keys = nil + do + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for i = 3, (#ast - 1) do + local val_19_ = str1(compiler.compile1(ast[i], scope, parent, {nval = 1})) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end + end + keys = tbl_17_ + end + local value = str1(compiler.compile1(ast[#ast], scope, parent, {nval = 1})) + local fmtstr = nil + if needs_separator_3f(root0, get_prev_line(parent)) then + fmtstr = "do end %s[%s] = %s" else fmtstr = "%s[%s] = %s" end - return compiler.emit(parent, fmtstr:format(rootstr, table.concat(keys, "]["), tostring(value)), ast) + return compiler.emit(parent, fmtstr:format(root0, table.concat(keys, "]["), value), ast) end - doc_special("tset", {"tbl", "key1", "...", "keyN", "val"}, "Set the value of a table field. Can take additional keys to set\nnested values, but all parents must contain an existing table.") - local function calculate_target(scope, opts) + doc_special("tset", {"tbl", "key1", "...", "keyN", "val"}, "Set the value of a table field. Deprecated in favor of set.") + local function calculate_if_target(scope, opts) if not (opts.tail or opts.target or opts.nval) then return "iife", true, nil elseif (opts.nval and (opts.nval ~= 0) and not opts.target) then @@ -1521,7 +1562,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local target_exprs = {} for i = 1, opts.nval do local s = compiler.gensym(scope) - do end (accum)[i] = s + accum[i] = s target_exprs[i] = utils.expr(s, "sym") end return "target", opts.tail, table.concat(accum, ", "), target_exprs @@ -1531,134 +1572,185 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end local function if_2a(ast, scope, parent, opts) compiler.assert((2 < #ast), "expected condition and body", ast) - local do_scope = compiler["make-scope"](scope) - local branches = {} - local wrapper, inner_tail, inner_target, target_exprs = calculate_target(scope, opts) - local body_opts = {nval = opts.nval, tail = inner_tail, target = inner_target} - local function compile_body(i) - local chunk = {} - local cscope = compiler["make-scope"](do_scope) - compiler["keep-side-effects"](compiler.compile1(ast[i], cscope, chunk, body_opts), chunk, nil, ast[i]) - return {chunk = chunk, scope = cscope} + if ((1 == (#ast % 2)) and (ast[(#ast - 1)] == true)) then + table.remove(ast, (#ast - 1)) end if (1 == (#ast % 2)) then table.insert(ast, utils.sym("nil")) - else end - for i = 2, (#ast - 1), 2 do - local condchunk = {} - local res = compiler.compile1(ast[i], do_scope, condchunk, {nval = 1}) - local cond = res[1] - local branch = compile_body((i + 1)) - branch.cond = cond - branch.condchunk = condchunk - branch.nested = ((i ~= 2) and (next(condchunk, nil) == nil)) - table.insert(branches, branch) - end - local else_branch = compile_body(#ast) - local s = compiler.gensym(scope) - local buffer = {} - local last_buffer = buffer - for i = 1, #branches do - local branch = branches[i] - local fstr - if not branch.nested then - fstr = "if %s then" - else - fstr = "elseif %s then" - end - local cond = tostring(branch.cond) - local cond_line = fstr:format(cond) - if branch.nested then - compiler.emit(last_buffer, branch.condchunk, ast) - else - for _, v in ipairs(branch.condchunk) do - compiler.emit(last_buffer, v, ast) - end - end - compiler.emit(last_buffer, cond_line, ast) - compiler.emit(last_buffer, branch.chunk, ast) - if (i == #branches) then - compiler.emit(last_buffer, "else", ast) - compiler.emit(last_buffer, else_branch.chunk, ast) - compiler.emit(last_buffer, "end", ast) - elseif not (branches[(i + 1)]).nested then - local next_buffer = {} - compiler.emit(last_buffer, "else", ast) - compiler.emit(last_buffer, next_buffer, ast) - compiler.emit(last_buffer, "end", ast) - last_buffer = next_buffer + if (#ast == 2) then + return SPECIALS["do"](utils.list(utils.sym("do"), ast[2]), scope, parent, opts) + else + local do_scope = compiler["make-scope"](scope) + local branches = {} + local wrapper, inner_tail, inner_target, target_exprs = calculate_if_target(scope, opts) + local body_opts = {nval = opts.nval, tail = inner_tail, target = inner_target} + local function compile_body(i) + local chunk = {} + local cscope = compiler["make-scope"](do_scope) + compiler["keep-side-effects"](compiler.compile1(ast[i], cscope, chunk, body_opts), chunk, nil, ast[i]) + return {chunk = chunk, scope = cscope} + end + for i = 2, (#ast - 1), 2 do + local condchunk = {} + local _549_ = compiler.compile1(ast[i], do_scope, condchunk, {nval = 1}) + local cond = _549_[1] + local branch = compile_body((i + 1)) + branch.cond = cond + branch.condchunk = condchunk + branch.nested = ((i ~= 2) and (next(condchunk, nil) == nil)) + table.insert(branches, branch) + end + local else_branch = compile_body(#ast) + local s = compiler.gensym(scope) + local buffer = {} + local last_buffer = buffer + for i = 1, #branches do + local branch = branches[i] + local fstr = nil + if not branch.nested then + fstr = "if %s then" + else + fstr = "elseif %s then" + end + local cond = tostring(branch.cond) + local cond_line = fstr:format(cond) + if branch.nested then + compiler.emit(last_buffer, branch.condchunk, ast) + else + for _, v in ipairs(branch.condchunk) do + compiler.emit(last_buffer, v, ast) + end + end + compiler.emit(last_buffer, cond_line, ast) + compiler.emit(last_buffer, branch.chunk, ast) + if (i == #branches) then + compiler.emit(last_buffer, "else", ast) + compiler.emit(last_buffer, else_branch.chunk, ast) + compiler.emit(last_buffer, "end", ast) + elseif not branches[(i + 1)].nested then + local next_buffer = {} + compiler.emit(last_buffer, "else", ast) + compiler.emit(last_buffer, next_buffer, ast) + compiler.emit(last_buffer, "end", ast) + last_buffer = next_buffer + end + end + if (wrapper == "iife") then + local iifeargs = ((scope.vararg and "...") or "") + compiler.emit(parent, ("local function %s(%s)"):format(tostring(s), iifeargs), ast) + compiler.emit(parent, buffer, ast) + compiler.emit(parent, "end", ast) + return utils.expr(("%s(%s)"):format(tostring(s), iifeargs), "statement") + elseif (wrapper == "none") then + for i = 1, #buffer do + compiler.emit(parent, buffer[i], ast) + end + return {returned = true} else + compiler.emit(parent, ("local %s"):format(inner_target), ast) + for i = 1, #buffer do + compiler.emit(parent, buffer[i], ast) + end + return target_exprs end end - if (wrapper == "iife") then - local iifeargs = ((scope.vararg and "...") or "") - compiler.emit(parent, ("local function %s(%s)"):format(tostring(s), iifeargs), ast) - compiler.emit(parent, buffer, ast) - compiler.emit(parent, "end", ast) - return utils.expr(("%s(%s)"):format(tostring(s), iifeargs), "statement") - elseif (wrapper == "none") then - for i = 1, #buffer do - compiler.emit(parent, buffer[i], ast) - end - return {returned = true} - else - compiler.emit(parent, ("local %s"):format(inner_target), ast) - for i = 1, #buffer do - compiler.emit(parent, buffer[i], ast) - end - return target_exprs - end 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) - local last_item = bindings[(#bindings - 1)] - if ((utils["sym?"](last_item) and (tostring(last_item) == "&until")) or ("until" == last_item)) then - table.remove(bindings, (#bindings - 1)) - return table.remove(bindings) - else - return nil + local function clause_3f(v) + return (utils["string?"](v) or (utils["sym?"](v) and not utils["multi-sym?"](v) and tostring(v):match("^&(.+)"))) + end + local function remove_until_condition(bindings, ast) + local _until = nil + for i = (#bindings - 1), 3, -1 do + local _555_0 = clause_3f(bindings[i]) + if ((_555_0 == false) or (_555_0 == nil)) then + elseif (nil ~= _555_0) then + local clause = _555_0 + compiler.assert(((clause == "until") and not _until), ("unexpected iterator clause: " .. clause), ast) + table.remove(bindings, i) + _until = table.remove(bindings, i) + end + end + return _until + end + local function compile_until(_3fcondition, scope, chunk) + if _3fcondition then + local _557_ = compiler.compile1(_3fcondition, scope, chunk, {nval = 1}) + local condition_lua = _557_[1] + return compiler.emit(chunk, ("if %s then break end"):format(tostring(condition_lua)), utils.expr(_3fcondition, "expression")) end end - local function compile_until(condition, scope, chunk) - if condition then - local _let_502_ = compiler.compile1(condition, scope, chunk, {nval = 1}) - local condition_lua = _let_502_[1] - return compiler.emit(chunk, ("if %s then break end"):format(tostring(condition_lua)), utils.expr(condition, "expression")) + local function iterator_bindings(ast) + local bindings = utils.copy(ast) + local _3funtil = remove_until_condition(bindings, ast) + local iter = table.remove(bindings) + local bindings0 = nil + if (1 == #bindings) then + bindings0 = (utils["list?"](bindings[1]) or bindings) else - return nil + for _, b in ipairs(bindings) do + if utils["list?"](b) then + utils.warn("unexpected parens in iterator", b) + end + end + bindings0 = bindings end + return bindings0, iter, _3funtil end SPECIALS.each = function(ast, scope, parent) compiler.assert((3 <= #ast), "expected body expression", ast[1]) - local binding = compiler.assert(utils["table?"](ast[2]), "expected binding table", ast) - local _ = compiler.assert((2 <= #binding), "expected binding and iterator", binding) - local until_condition = remove_until_condition(binding) - local iter = table.remove(binding, #binding) - local destructures = {} - local new_manglings = {} + compiler.assert(utils["table?"](ast[2]), "expected binding table", ast) local sub_scope = compiler["make-scope"](scope) + local binding, iter, _3funtil_condition = iterator_bindings(ast[2]) + local destructures = {} + local deferred_scope_changes = {manglings = {}, symmeta = {}} + utils.hook("pre-each", ast, sub_scope, binding, iter, _3funtil_condition) local function destructure_binding(v) - compiler.assert(not utils["string?"](v), ("unexpected iterator clause " .. tostring(v)), binding) if utils["sym?"](v) then - return compiler["declare-local"](v, {}, sub_scope, ast, new_manglings) + return compiler["declare-local"](v, sub_scope, ast, nil, deferred_scope_changes) else local raw = utils.sym(compiler.gensym(sub_scope)) - do end (destructures)[raw] = v - return compiler["declare-local"](raw, {}, sub_scope, ast) + destructures[raw] = v + return compiler["declare-local"](raw, sub_scope, ast) + end + end + local bind_vars = nil + do + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for _, b in ipairs(binding) do + local val_19_ = destructure_binding(b) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end end + bind_vars = tbl_17_ end - local bind_vars = utils.map(binding, destructure_binding) local vals = compiler.compile1(iter, scope, parent) - local val_names = utils.map(vals, tostring) + local val_names = nil + do + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for _, v in ipairs(vals) do + local val_19_ = tostring(v) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end + end + val_names = tbl_17_ + end local chunk = {} + compiler.assert(bind_vars[1], "expected binding and iterator", ast) compiler.emit(parent, ("for %s in %s do"):format(table.concat(bind_vars, ", "), table.concat(val_names, ", ")), ast) for raw, args in utils.stablepairs(destructures) do compiler.destructure(args, raw, ast, sub_scope, chunk, {declaration = true, nomulti = true, symtype = "each"}) end - compiler["apply-manglings"](sub_scope, new_manglings, ast) - compile_until(until_condition, sub_scope, chunk) + compiler["apply-deferred-scope-changes"](sub_scope, deferred_scope_changes, ast) + compile_until(_3funtil_condition, sub_scope, chunk) compile_do(ast, sub_scope, chunk, 3) compiler.emit(parent, chunk, ast) return compiler.emit(parent, "end", ast) @@ -1666,13 +1758,13 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct doc_special("each", {"[key value (iterator)]", "..."}, "Runs the body once for each set of values provided by the given iterator.\nMost commonly used with ipairs for sequential tables or pairs for undefined\norder, but can be used with any iterator.", true) local function while_2a(ast, scope, parent) local len1 = #parent - local condition = (compiler.compile1(ast[2], scope, parent, {nval = 1}))[1] + local condition = compiler.compile1(ast[2], scope, parent, {nval = 1})[1] local len2 = #parent local sub_chunk = {} if (len1 ~= len2) then for i = (len1 + 1), len2 do table.insert(sub_chunk, parent[i]) - do end (parent)[i] = nil + parent[i] = nil end compiler.emit(parent, "while true do", ast) compiler.emit(sub_chunk, ("if not %s then break end"):format(condition[1]), ast) @@ -1686,19 +1778,22 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct SPECIALS["while"] = while_2a doc_special("while", {"condition", "..."}, "The classic while loop. Evaluates body until a condition is non-truthy.", true) local function for_2a(ast, scope, parent) - local ranges = compiler.assert(utils["table?"](ast[2]), "expected binding table", ast) - local until_condition = remove_until_condition(ast[2]) - local binding_sym = table.remove(ast[2], 1) + compiler.assert(utils["table?"](ast[2]), "expected binding table", ast) + local ranges = setmetatable(utils.copy(ast[2]), getmetatable(ast[2])) + local until_condition = remove_until_condition(ranges, ast) + local binding_sym = table.remove(ranges, 1) local sub_scope = compiler["make-scope"](scope) local range_args = {} local chunk = {} compiler.assert(utils["sym?"](binding_sym), ("unable to bind %s %s"):format(type(binding_sym), tostring(binding_sym)), ast[2]) compiler.assert((3 <= #ast), "expected body expression", ast[1]) - compiler.assert((#ranges <= 3), "unexpected arguments", ranges[4]) + compiler.assert((#ranges <= 3), "unexpected arguments", ranges) + compiler.assert((1 < #ranges), "expected range to include start and stop", ranges) + utils.hook("pre-for", ast, sub_scope, binding_sym) for i = 1, math.min(#ranges, 3) do - range_args[i] = tostring((compiler.compile1(ranges[i], scope, parent, {nval = 1}))[1]) + range_args[i] = str1(compiler.compile1(ranges[i], scope, parent, {nval = 1})) end - compiler.emit(parent, ("for %s = %s do"):format(compiler["declare-local"](binding_sym, {}, sub_scope, ast), table.concat(range_args, ", ")), ast) + 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) @@ -1706,13 +1801,22 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end SPECIALS["for"] = for_2a doc_special("for", {"[index start stop step?]", "..."}, "Numeric loop construct.\nEvaluates body once for each value between start and stop (inclusive).", true) + local function method_special_type(ast) + if (utils["string?"](ast[3]) and utils["valid-lua-identifier?"](ast[3])) then + return "native" + elseif utils["sym?"](ast[2]) then + return "nonnative" + else + return "binding" + end + end local function native_method_call(ast, _scope, _parent, target, args) - local _let_506_ = ast - local _ = _let_506_[1] - local _0 = _let_506_[2] - local method_string = _let_506_[3] - local call_string - if ((target.type == "literal") or (target.type == "varg") or (target.type == "expression")) then + local _566_ = ast + local _ = _566_[1] + local _0 = _566_[2] + local method_string = _566_[3] + local call_string = nil + if ((target.type == "literal") or (target.type == "varg") or ((target.type == "expression") and not (target[1]):match("[%)%]]$") and not (target[1]):match("%.[%a_][%w_]*$"))) then call_string = "(%s):%s(%s)" else call_string = "%s:%s(%s)" @@ -1720,52 +1824,78 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return utils.expr(string.format(call_string, tostring(target), method_string, table.concat(args, ", ")), "statement") end local function nonnative_method_call(ast, scope, parent, target, args) - local method_string = tostring((compiler.compile1(ast[3], scope, parent, {nval = 1}))[1]) + local method_string = str1(compiler.compile1(ast[3], scope, parent, {nval = 1})) local args0 = {tostring(target), unpack(args)} return utils.expr(string.format("%s[%s](%s)", tostring(target), method_string, table.concat(args0, ", ")), "statement") end - local function double_eval_protected_method_call(ast, scope, parent, target, args) - local method_string = tostring((compiler.compile1(ast[3], scope, parent, {nval = 1}))[1]) - local call = "(function(tgt, m, ...) return tgt[m](tgt, ...) end)(%s, %s)" - table.insert(args, 1, method_string) - return utils.expr(string.format(call, tostring(target), table.concat(args, ", ")), "statement") + local function binding_method_call(ast, scope, parent, target, args) + local method_string = str1(compiler.compile1(ast[3], scope, parent, {nval = 1})) + local target_local = compiler.gensym(scope, "tgt") + local args0 = {target_local, unpack(args)} + compiler.emit(parent, string.format("local %s = %s", target_local, tostring(target))) + return utils.expr(string.format("(%s)[%s](%s)", target_local, method_string, table.concat(args0, ", ")), "statement") end local function method_call(ast, scope, parent) compiler.assert((2 < #ast), "expected at least 2 arguments", ast) - local _let_508_ = compiler.compile1(ast[2], scope, parent, {nval = 1}) - local target = _let_508_[1] + local _568_ = compiler.compile1(ast[2], scope, parent, {nval = 1}) + local target = _568_[1] local args = {} for i = 4, #ast do - local subexprs - local _509_ + local subexprs = nil + local _569_ if (i ~= #ast) then - _509_ = 1 + _569_ = 1 else - _509_ = nil + _569_ = nil + end + subexprs = compiler.compile1(ast[i], scope, parent, {nval = _569_}) + local tbl_17_ = args + local i_18_ = #tbl_17_ + for _, subexpr in ipairs(subexprs) do + local val_19_ = tostring(subexpr) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end end - subexprs = compiler.compile1(ast[i], scope, parent, {nval = _509_}) - utils.map(subexprs, tostring, args) end - if (utils["string?"](ast[3]) and utils["valid-lua-identifier?"](ast[3])) then + local _572_0 = method_special_type(ast) + if (_572_0 == "native") then return native_method_call(ast, scope, parent, target, args) - elseif (target.type == "sym") then + elseif (_572_0 == "nonnative") then return nonnative_method_call(ast, scope, parent, target, args) - else - return double_eval_protected_method_call(ast, scope, parent, target, args) + elseif (_572_0 == "binding") then + return binding_method_call(ast, scope, parent, target, args) end end SPECIALS[":"] = method_call doc_special(":", {"tbl", "method-name", "..."}, "Call the named method on tbl with the provided args.\nMethod name doesn't have to be known at compile-time; if it is, use\n(tbl:method-name ...) instead.") SPECIALS.comment = function(ast, _, parent) - local els = {} - for i = 2, #ast do - table.insert(els, view(ast[i], {["one-line?"] = true})) + local c = nil + local _574_ + do + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for i, elt in ipairs(ast) do + local val_19_ = nil + if (i ~= 1) then + val_19_ = view(elt, {["one-line?"] = true}) + else + val_19_ = nil + end + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end + end + _574_ = tbl_17_ end - return compiler.emit(parent, ("--[[ " .. table.concat(els, " ") .. " ]]"), ast) + c = table.concat(_574_, " "):gsub("%]%]", "]\\]") + return compiler.emit(parent, ("--[[ " .. c .. " ]]"), ast) end doc_special("comment", {"..."}, "Comment which will be emitted in Lua output.", true) local function hashfn_max_used(f_scope, i, max) - local max0 + local max0 = nil if f_scope.symmeta[("$" .. i)].used then max0 = i else @@ -1779,38 +1909,41 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end SPECIALS.hashfn = function(ast, scope, parent) compiler.assert((#ast == 2), "expected one argument", ast) - local f_scope + local f_scope = nil do - local _514_ = compiler["make-scope"](scope) - do end (_514_)["vararg"] = false - _514_["hashfn"] = true - f_scope = _514_ + local _579_0 = compiler["make-scope"](scope) + _579_0["vararg"] = false + _579_0["hashfn"] = true + f_scope = _579_0 end local f_chunk = {} local name = compiler.gensym(scope) local symbol = utils.sym(name) local args = {} - compiler["declare-local"](symbol, {}, scope, ast) + compiler["declare-local"](symbol, scope, ast) for i = 1, 9 do - args[i] = compiler["declare-local"](utils.sym(("$" .. i)), {}, f_scope, ast) + args[i] = compiler["declare-local"](utils.sym(("$" .. i)), f_scope, ast) end - local function walker(idx, node, parent_node) - if (utils["sym?"](node) and (tostring(node) == "$...")) then - parent_node[idx] = utils.varg() + local function walker(idx, node, _3fparent_node) + if utils["sym?"](node, "$...") then f_scope.vararg = true - return nil + if _3fparent_node then + _3fparent_node[idx] = utils.varg() + return nil + else + return utils.varg() + end else - return (("table" == type(node)) and (utils.sym("hashfn") ~= node[1]) and (utils["list?"](node) or utils["table?"](node))) + return ((utils["list?"](node) and (not _3fparent_node or not utils["sym?"](node[1], "hashfn"))) or utils["table?"](node)) end end - utils["walk-tree"](ast[2], walker) + utils["walk-tree"](ast, walker) compiler.compile1(ast[2], f_scope, f_chunk, {tail = true}) local max_used = hashfn_max_used(f_scope, 1, 0) if f_scope.vararg then compiler.assert((max_used == 0), "$ and $... in hashfn are mutually exclusive", ast) - else end - local arg_str + local arg_str = nil if f_scope.vararg then arg_str = tostring(utils.varg()) else @@ -1822,78 +1955,164 @@ 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 maybe_short_circuit_protect(ast, i, name, _518_) - local _arg_519_ = _518_ - local mac = _arg_519_["macros"] - local call = (utils["list?"](ast) and tostring(ast[1])) - if ((("or" == name) or ("and" == name)) and (1 < i) and (mac[call] or ("set" == call) or ("tset" == call) or ("global" == call))) then - return utils.list(utils.sym("do"), ast) + local function comparator_special_type(ast) + if (3 == #ast) then + return "native" + elseif utils["every?"]({unpack(ast, 3, (#ast - 1))}, utils["idempotent-expr?"]) then + return "idempotent" else - return ast + return "binding" end end - local function arithmetic_special(name, zero_arity, unary_prefix, ast, scope, parent) - local len = #ast - local operands = {} - local padded_op = (" " .. name .. " ") - for i = 2, len do - local subast = maybe_short_circuit_protect(ast[i], i, name, scope) - local subexprs = compiler.compile1(subast, scope, parent) - if (i == len) then - utils.map(subexprs, tostring, operands) + local function short_circuit_safe_3f(x, scope) + if (("table" ~= type(x)) or utils["sym?"](x) or utils["varg?"](x)) then + return true + elseif utils["table?"](x) then + local ok = true + for k, v in pairs(x) do + if not ok then break end + ok = (short_circuit_safe_3f(v, scope) and short_circuit_safe_3f(k, scope)) + end + return ok + elseif utils["list?"](x) then + if utils["sym?"](x[1]) then + local _585_0 = str1(x) + if ((_585_0 == "fn") or (_585_0 == "hashfn") or (_585_0 == "let") or (_585_0 == "local") or (_585_0 == "var") or (_585_0 == "set") or (_585_0 == "tset") or (_585_0 == "if") or (_585_0 == "each") or (_585_0 == "for") or (_585_0 == "while") or (_585_0 == "do") or (_585_0 == "lua") or (_585_0 == "global")) then + return false + elseif (((_585_0 == "<") or (_585_0 == ">") or (_585_0 == "<=") or (_585_0 == ">=") or (_585_0 == "=") or (_585_0 == "not=") or (_585_0 == "~=")) and (comparator_special_type(x) == "binding")) then + return false + else + local function _586_() + return (1 ~= x[2]) + end + if ((_585_0 == "pick-values") and _586_()) then + return false + else + local function _587_() + local call = _585_0 + return scope.macros[call] + end + if ((nil ~= _585_0) and _587_()) then + local call = _585_0 + return false + else + local function _588_() + return (method_special_type(x) == "binding") + end + if ((_585_0 == ":") and _588_()) then + return false + else + local _ = _585_0 + local ok = true + for i = 2, #x do + if not ok then break end + ok = short_circuit_safe_3f(x[i], scope) + end + return ok + end + end + end + end else - table.insert(operands, tostring(subexprs[1])) + local ok = true + for _, v in ipairs(x) do + if not ok then break end + ok = short_circuit_safe_3f(v, scope) + end + return ok end end - local _522_ = #operands - if (_522_ == 0) then - local _524_ - do - local _523_ = zero_arity - compiler.assert(_523_, "Expected more than 0 arguments", ast) - _524_ = _523_ + end + local function operator_special_result(ast, zero_arity, unary_prefix, padded_op, operands) + local _592_0 = #operands + if (_592_0 == 0) then + if zero_arity then + return utils.expr(zero_arity, "literal") + else + return compiler.assert(false, "Expected more than 0 arguments", ast) end - return utils.expr(_524_, "literal") - elseif (_522_ == 1) then + elseif (_592_0 == 1) then if unary_prefix then return ("(" .. unary_prefix .. padded_op .. operands[1] .. ")") else return operands[1] end - elseif true then - local _ = _522_ - return ("(" .. table.concat(operands, padded_op) .. ")") else - return nil + local _ = _592_0 + return ("(" .. table.concat(operands, padded_op) .. ")") end end + local function emit_short_circuit_if(ast, scope, parent, name, subast, accumulator, expr_string, setter) + if (accumulator ~= expr_string) then + compiler.emit(parent, string.format(setter, accumulator, expr_string), ast) + end + local function _597_() + if (name == "and") then + return accumulator + else + return ("not " .. accumulator) + end + end + compiler.emit(parent, ("if %s then"):format(_597_()), subast) + do + local chunk = {} + compiler.compile1(subast, scope, chunk, {nval = 1, target = accumulator}) + compiler.emit(parent, chunk) + end + return compiler.emit(parent, "end") + end + local function operator_special(name, zero_arity, unary_prefix, ast, scope, parent) + compiler.assert(not ((#ast == 2) and utils["varg?"](ast[2])), "tried to use vararg with operator", ast) + local padded_op = (" " .. name .. " ") + local operands, accumulator = {} + if utils["call-of?"](ast[#ast], "values") then + utils.warn("multiple values in operators are deprecated", ast) + end + for subast in iter_args(ast) do + if ((nil ~= next(operands)) and ((name == "or") or (name == "and")) and not short_circuit_safe_3f(subast, scope)) then + local expr_string = table.concat(operands, padded_op) + local setter = nil + if accumulator then + setter = "%s = %s" + else + setter = "local %s = %s" + end + if not accumulator then + accumulator = compiler.gensym(scope, name) + end + emit_short_circuit_if(ast, scope, parent, name, subast, accumulator, expr_string, setter) + operands = {accumulator} + else + table.insert(operands, str1(compiler.compile1(subast, scope, parent, {nval = 1}))) + end + end + return operator_special_result(ast, zero_arity, unary_prefix, padded_op, operands) + end local function define_arithmetic_special(name, zero_arity, unary_prefix, _3flua_name) - local _530_ + local _603_ do - local _527_ = (_3flua_name or name) - local _528_ = zero_arity - local _529_ = unary_prefix - local function _531_(...) - return arithmetic_special(_527_, _528_, _529_, ...) + local _602_0 = (_3flua_name or name) + local function _604_(...) + return operator_special(_602_0, zero_arity, unary_prefix, ...) end - _530_ = _531_ + _603_ = _604_ end - SPECIALS[name] = _530_ + SPECIALS[name] = _603_ return doc_special(name, {"a", "b", "..."}, "Arithmetic operator; works the same as Lua but accepts more arguments.") end - define_arithmetic_special("+", "0") + define_arithmetic_special("+", "0", "0") define_arithmetic_special("..", "''") define_arithmetic_special("^") define_arithmetic_special("-", nil, "") - define_arithmetic_special("*", "1") + define_arithmetic_special("*", "1", "1") define_arithmetic_special("%") define_arithmetic_special("/", nil, "1") define_arithmetic_special("//", nil, "1") SPECIALS["or"] = function(ast, scope, parent) - return arithmetic_special("or", "false", nil, ast, scope, parent) + return operator_special("or", "false", nil, ast, scope, parent) end SPECIALS["and"] = function(ast, scope, parent) - return arithmetic_special("and", "true", nil, ast, scope, parent) + return operator_special("and", "true", nil, ast, scope, parent) end doc_special("and", {"a", "b", "..."}, "Boolean operator; works the same as Lua but accepts more arguments.") doc_special("or", {"a", "b", "..."}, "Boolean operator; works the same as Lua but accepts more arguments.") @@ -1906,15 +2125,23 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local padded_native_name = (" " .. native_name .. " ") local prefixed_lib_name = ("bit." .. lib_name) for i = 2, len do - local subexprs - local _532_ + local subexprs = nil + local _605_ if (i ~= len) then - _532_ = 1 + _605_ = 1 else - _532_ = nil + _605_ = nil + end + subexprs = compiler.compile1(ast[i], scope, parent, {nval = _605_}) + local tbl_17_ = operands + local i_18_ = #tbl_17_ + for _, s in ipairs(subexprs) do + local val_19_ = tostring(s) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end end - subexprs = compiler.compile1(ast[i], scope, parent, {nval = _532_}) - utils.map(subexprs, tostring, operands) end if (#operands == 1) then if utils.root.options.useBitLib then @@ -1932,23 +2159,15 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end end local function define_bitop_special(name, zero_arity, unary_prefix, native) - local _542_ - do - local _538_ = native - local _539_ = name - local _540_ = zero_arity - local _541_ = unary_prefix - local function _543_(...) - return bitop_special(_538_, _539_, _540_, _541_, ...) - end - _542_ = _543_ + local function _612_(...) + return bitop_special(native, name, zero_arity, unary_prefix, ...) end - SPECIALS[name] = _542_ + SPECIALS[name] = _612_ return nil end define_bitop_special("lshift", nil, "1", "<<") define_bitop_special("rshift", nil, "1", ">>") - define_bitop_special("band", "0", "0", "&") + define_bitop_special("band", "-1", "-1", "&") 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.") @@ -1956,84 +2175,106 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct 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.") + SPECIALS.bnot = function(ast, scope, parent) + compiler.assert((#ast == 2), "expected one argument", ast) + local _613_ = compiler.compile1(ast[2], scope, parent, {nval = 1}) + local value = _613_[1] + if utils.root.options.useBitLib then + return ("bit.bnot(" .. tostring(value) .. ")") + else + return ("~(" .. tostring(value) .. ")") + end + end + doc_special("bnot", {"x"}, "Bitwise negation; only works in Lua 5.3+ or LuaJIT with the --use-bit-lib flag.") doc_special("..", {"a", "b", "..."}, "String concatenation operator; works the same as Lua but accepts more arguments.") - local function native_comparator(op, _544_, scope, parent) - local _arg_545_ = _544_ - local _ = _arg_545_[1] - local lhs_ast = _arg_545_[2] - local rhs_ast = _arg_545_[3] - local _let_546_ = compiler.compile1(lhs_ast, scope, parent, {nval = 1}) - local lhs = _let_546_[1] - local _let_547_ = compiler.compile1(rhs_ast, scope, parent, {nval = 1}) - local rhs = _let_547_[1] + local function native_comparator(op, _615_0, scope, parent) + local _616_ = _615_0 + local _ = _616_[1] + local lhs_ast = _616_[2] + local rhs_ast = _616_[3] + local _617_ = compiler.compile1(lhs_ast, scope, parent, {nval = 1}) + local lhs = _617_[1] + local _618_ = compiler.compile1(rhs_ast, scope, parent, {nval = 1}) + local rhs = _618_[1] return string.format("(%s %s %s)", tostring(lhs), op, tostring(rhs)) end local function idempotent_comparator(op, chain_op, ast, scope, parent) - local vals + local vals = nil do - local tbl_16_auto = {} - local i_17_auto = #tbl_16_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ for i = 2, #ast do - local val_18_auto = tostring((compiler.compile1(ast[i], scope, parent, {nval = 1}))[1]) - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + local val_19_ = str1(compiler.compile1(ast[i], scope, parent, {nval = 1})) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - vals = tbl_16_auto + vals = tbl_17_ end - local comparisons + local comparisons = nil do - local tbl_16_auto = {} - local i_17_auto = #tbl_16_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ for i = 1, (#vals - 1) do - local val_18_auto = string.format("(%s %s %s)", vals[i], op, vals[(i + 1)]) - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + local val_19_ = string.format("(%s %s %s)", vals[i], op, vals[(i + 1)]) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - comparisons = tbl_16_auto + comparisons = tbl_17_ end local chain = string.format(" %s ", (chain_op or "and")) - return table.concat(comparisons, chain) + return ("(" .. table.concat(comparisons, chain) .. ")") end - local function double_eval_protected_comparator(op, chain_op, ast, scope, parent) - local arglist = {} - local comparisons = {} + local function binding_comparator(op, chain_op, ast, scope, parent) + local binding_left = {} + local binding_right = {} local vals = {} local chain = string.format(" %s ", (chain_op or "and")) for i = 2, #ast do - table.insert(arglist, tostring(compiler.gensym(scope))) - table.insert(vals, tostring((compiler.compile1(ast[i], scope, parent, {nval = 1}))[1])) + local compiled = str1(compiler.compile1(ast[i], scope, parent, {nval = 1})) + if (utils["idempotent-expr?"](ast[i]) or (i == 2) or (i == #ast)) then + table.insert(vals, compiled) + else + local my_sym = compiler.gensym(scope) + table.insert(binding_left, my_sym) + table.insert(binding_right, compiled) + table.insert(vals, my_sym) + end end + compiler.emit(parent, string.format("local %s = %s", table.concat(binding_left, ", "), table.concat(binding_right, ", "), ast)) + local _622_ do - local tbl_16_auto = comparisons - local i_17_auto = #tbl_16_auto - for i = 1, (#arglist - 1) do - local val_18_auto = string.format("(%s %s %s)", arglist[i], op, arglist[(i + 1)]) - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for i = 1, (#vals - 1) do + local val_19_ = string.format("(%s %s %s)", vals[i], op, vals[(i + 1)]) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end + _622_ = tbl_17_ end - return string.format("(function(%s) return %s end)(%s)", table.concat(arglist, ","), table.concat(comparisons, chain), table.concat(vals, ",")) + return ("(" .. table.concat(_622_, chain) .. ")") end local function define_comparator_special(name, _3flua_op, _3fchain_op) do local op = (_3flua_op or name) local function opfn(ast, scope, parent) compiler.assert((2 < #ast), "expected at least two arguments", ast) - if (3 == #ast) then + local _624_0 = comparator_special_type(ast) + if (_624_0 == "native") then return native_comparator(op, ast, scope, parent) - elseif utils["every?"](utils["idempotent-expr?"], {unpack(ast, 2)}) then + elseif (_624_0 == "idempotent") then return idempotent_comparator(op, _3fchain_op, ast, scope, parent) + elseif (_624_0 == "binding") then + return binding_comparator(op, _3fchain_op, ast, scope, parent) else - return double_eval_protected_comparator(op, _3fchain_op, ast, scope, parent) + local _ = _624_0 + return error("internal compiler error. please report this to the fennel devs.") end end SPECIALS[name] = opfn @@ -2050,18 +2291,16 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local function opfn(ast, scope, parent) compiler.assert((#ast == 2), "expected one argument", ast) local tail = compiler.compile1(ast[2], scope, parent, {nval = 1}) - return ((_3frealop or op) .. tostring(tail[1])) + return ((_3frealop or op) .. str1(tail)) end SPECIALS[op] = opfn return nil end 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+ or LuaJIT with the --use-bit-lib flag.") define_unary_special("length", "#") doc_special("length", {"x"}, "Returns the length of a table or string.") - do end (SPECIALS)["~="] = SPECIALS["not="] + SPECIALS["~="] = SPECIALS["not="] SPECIALS["#"] = SPECIALS.length SPECIALS.quote = function(ast, scope, parent) compiler.assert((#ast == 2), "expected one argument", ast) @@ -2070,7 +2309,6 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct this_scope = this_scope.parent if (this_scope == compiler.scopes.compiler) then runtime = false - else end end return compiler["do-quote"](ast[2], scope, parent, runtime) @@ -2084,26 +2322,25 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end local safe_require = nil local function safe_compiler_env() - local _554_ + local _628_ do - local _553_ = rawget(_G, "utf8") - if (nil ~= _553_) then - _554_ = utils.copy(_553_) + local _627_0 = rawget(_G, "utf8") + if (nil ~= _627_0) then + _628_ = utils.copy(_627_0) else - _554_ = _553_ + _628_ = _627_0 end end - return {table = utils.copy(table), math = utils.copy(math), string = utils.copy(string), pairs = utils.stablepairs, ipairs = ipairs, select = select, tostring = tostring, tonumber = tonumber, bit = rawget(_G, "bit"), pcall = pcall, xpcall = xpcall, next = next, print = print, type = type, assert = assert, error = error, setmetatable = setmetatable, getmetatable = safe_getmetatable, require = safe_require, rawlen = rawget(_G, "rawlen"), rawget = rawget, rawset = rawset, rawequal = rawequal, _VERSION = _VERSION, utf8 = _554_} + return {_VERSION = _VERSION, assert = assert, bit = rawget(_G, "bit"), error = error, getmetatable = safe_getmetatable, ipairs = ipairs, math = utils.copy(math), next = next, pairs = utils.stablepairs, 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, utf8 = _628_, xpcall = xpcall} end local function combined_mt_pairs(env) local combined = {} - local _let_556_ = getmetatable(env) - local __index = _let_556_["__index"] + local _630_ = getmetatable(env) + local __index = _630_["__index"] if ("table" == type(__index)) then for k, v in pairs(__index) do combined[k] = v end - else end for k, v in next, env, nil do combined[k] = v @@ -2111,61 +2348,58 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return next, combined, nil end local function make_compiler_env(ast, scope, parent, _3fopts) - local provided + local provided = nil do - local _558_ = (_3fopts or utils.root.options) - if ((_G.type(_558_) == "table") and ((_558_)["compiler-env"] == "strict")) then + local _632_0 = (_3fopts or utils.root.options) + if ((_G.type(_632_0) == "table") and (_632_0["compiler-env"] == "strict")) then provided = safe_compiler_env() - elseif ((_G.type(_558_) == "table") and (nil ~= (_558_).compilerEnv)) then - local compilerEnv = (_558_).compilerEnv + elseif ((_G.type(_632_0) == "table") and (nil ~= _632_0.compilerEnv)) then + local compilerEnv = _632_0.compilerEnv provided = compilerEnv - elseif ((_G.type(_558_) == "table") and (nil ~= (_558_)["compiler-env"])) then - local compiler_env = (_558_)["compiler-env"] + elseif ((_G.type(_632_0) == "table") and (nil ~= _632_0["compiler-env"])) then + local compiler_env = _632_0["compiler-env"] provided = compiler_env - elseif true then - local _ = _558_ - provided = safe_compiler_env(false) else - provided = nil + local _ = _632_0 + provided = safe_compiler_env() end end - local env - local function _560_(base) - return utils.sym(compiler.gensym((compiler.scopes.macro or scope), base)) - end - local function _561_() + local env = nil + local function _634_() return compiler.scopes.macro end - local function _562_(symbol) + local function _635_(symbol) compiler.assert(compiler.scopes.macro, "must call from macro", ast) return compiler.scopes.macro.manglings[tostring(symbol)] end - local function _563_(form) + local function _636_(base) + return utils.sym(compiler.gensym((compiler.scopes.macro or scope), base)) + end + local function _637_(form) compiler.assert(compiler.scopes.macro, "must call from macro", ast) return compiler.macroexpand(form, compiler.scopes.macro) end - env = {_AST = ast, _CHUNK = parent, _IS_COMPILER = true, _SCOPE = scope, _SPECIALS = compiler.scopes.global.specials, _VARARG = utils.varg(), ["macro-loaded"] = macro_loaded, unpack = unpack, ["assert-compile"] = compiler.assert, view = view, version = utils.version, metadata = compiler.metadata, ["ast-source"] = utils["ast-source"], list = utils.list, ["list?"] = utils["list?"], ["table?"] = utils["table?"], sequence = utils.sequence, ["sequence?"] = utils["sequence?"], sym = utils.sym, ["sym?"] = utils["sym?"], ["multi-sym?"] = utils["multi-sym?"], comment = utils.comment, ["comment?"] = utils["comment?"], ["varg?"] = utils["varg?"], gensym = _560_, ["get-scope"] = _561_, ["in-scope?"] = _562_, macroexpand = _563_} + env = {["assert-compile"] = compiler.assert, ["ast-source"] = utils["ast-source"], ["comment?"] = utils["comment?"], ["fennel-module-name"] = fennel_module_name, ["get-scope"] = _634_, ["in-scope?"] = _635_, ["list?"] = utils["list?"], ["macro-loaded"] = macro_loaded, ["multi-sym?"] = utils["multi-sym?"], ["sequence?"] = utils["sequence?"], ["sym?"] = utils["sym?"], ["table?"] = utils["table?"], ["varg?"] = utils["varg?"], _AST = ast, _CHUNK = parent, _IS_COMPILER = true, _SCOPE = scope, _SPECIALS = compiler.scopes.global.specials, _VARARG = utils.varg(), comment = utils.comment, gensym = _636_, list = utils.list, macroexpand = _637_, sequence = utils.sequence, sym = utils.sym, unpack = unpack, version = utils.version, view = view} env._G = env return setmetatable(env, {__index = provided, __newindex = provided, __pairs = combined_mt_pairs}) end - local function _565_(...) - local tbl_16_auto = {} - local i_17_auto = #tbl_16_auto + local function _638_(...) + local tbl_17_ = {} + local i_18_ = #tbl_17_ for c in string.gmatch((package.config or ""), "([^\n]+)") do - local val_18_auto = c - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + local val_19_ = c + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - return tbl_16_auto + return tbl_17_ end - local _local_564_ = _565_(...) - local dirsep = _local_564_[1] - local pathsep = _local_564_[2] - local pathmark = _local_564_[3] - local pkg_config = {dirsep = (dirsep or "/"), pathmark = (pathmark or ";"), pathsep = (pathsep or "?")} + local _640_ = _638_(...) + local dirsep = _640_[1] + local pathsep = _640_[2] + local pathmark = _640_[3] + local pkg_config = {dirsep = (dirsep or "/"), pathmark = (pathmark or "?"), pathsep = (pathsep or ";")} local function escapepat(str) return string.gsub(str, "[^%w]", "%%%1") end @@ -2177,40 +2411,36 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local function try_path(path) local filename = path:gsub(escapepat(pkg_config.pathmark), no_dot_module) local filename2 = path:gsub(escapepat(pkg_config.pathmark), modulename) - local _567_ = (io.open(filename) or io.open(filename2)) - if (nil ~= _567_) then - local file = _567_ + local _641_0 = (io.open(filename) or io.open(filename2)) + if (nil ~= _641_0) then + local file = _641_0 file:close() return filename - elseif true then - local _ = _567_ - return nil, ("no file '" .. filename .. "'") else - return nil + local _ = _641_0 + return nil, ("no file '" .. filename .. "'") end end local function find_in_path(start, _3ftried_paths) - local _569_ = fullpath:match(pattern, start) - if (nil ~= _569_) then - local path = _569_ - local _570_, _571_ = try_path(path) - if (nil ~= _570_) then - local filename = _570_ + local _643_0 = fullpath:match(pattern, start) + if (nil ~= _643_0) then + local path = _643_0 + local _644_0, _645_0 = try_path(path) + if (nil ~= _644_0) then + local filename = _644_0 return filename - elseif ((_570_ == nil) and (nil ~= _571_)) then - local error = _571_ - local function _573_() - local _572_ = (_3ftried_paths or {}) - table.insert(_572_, error) - return _572_ + elseif ((_644_0 == nil) and (nil ~= _645_0)) then + local error = _645_0 + local function _647_() + local _646_0 = (_3ftried_paths or {}) + table.insert(_646_0, error) + return _646_0 end - return find_in_path((start + #path + 1), _573_()) - else - return nil + return find_in_path((start + #path + 1), _647_()) end - elseif true then - local _ = _569_ - local function _575_() + else + local _ = _643_0 + local function _649_() local tried_paths = table.concat((_3ftried_paths or {}), "\n\9") if (_VERSION < "Lua 5.4") then return ("\n\9" .. tried_paths) @@ -2218,41 +2448,31 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return tried_paths end end - return nil, _575_() - else - return nil + return nil, _649_() end end return find_in_path(1) end local function make_searcher(_3foptions) - local function _578_(module_name) + local function _652_(module_name) local opts = utils.copy(utils.root.options) for k, v in pairs((_3foptions or {})) do opts[k] = v end opts["module-name"] = module_name - local _579_, _580_ = search_module(module_name) - if (nil ~= _579_) then - local filename = _579_ - local _583_ - do - local _581_ = filename - local _582_ = opts - local function _584_(...) - return utils["fennel-module"].dofile(_581_, _582_, ...) - end - _583_ = _584_ - end - return _583_, filename - elseif ((_579_ == nil) and (nil ~= _580_)) then - local error = _580_ + local _653_0, _654_0 = search_module(module_name) + if (nil ~= _653_0) then + local filename = _653_0 + local function _655_(...) + return utils["fennel-module"].dofile(filename, opts, ...) + end + return _655_, filename + elseif ((_653_0 == nil) and (nil ~= _654_0)) then + local error = _654_0 return error - else - return nil end end - return _578_ + return _652_ end local function dofile_with_searcher(fennel_macro_searcher, filename, opts, ...) local searchers = (package.loaders or package.searchers or {}) @@ -2262,116 +2482,104 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return m end local function fennel_macro_searcher(module_name) - local opts + local opts = nil do - local _586_ = utils.copy(utils.root.options) - do end (_586_)["module-name"] = module_name - _586_["env"] = "_COMPILER" - _586_["requireAsInclude"] = false - _586_["allowedGlobals"] = nil - opts = _586_ - end - local _587_ = search_module(module_name, utils["fennel-module"]["macro-path"]) - if (nil ~= _587_) then - local filename = _587_ - local _588_ + local _657_0 = utils.copy(utils.root.options) + _657_0["module-name"] = module_name + _657_0["env"] = "_COMPILER" + _657_0["requireAsInclude"] = false + _657_0["allowedGlobals"] = nil + opts = _657_0 + end + local _658_0 = search_module(module_name, utils["fennel-module"]["macro-path"]) + if (nil ~= _658_0) then + local filename = _658_0 + local _659_ if (opts["compiler-env"] == _G) then - local _589_ = fennel_macro_searcher - local _590_ = filename - local _591_ = opts - local function _593_(...) - return dofile_with_searcher(_589_, _590_, _591_, ...) + local function _660_(...) + return dofile_with_searcher(fennel_macro_searcher, filename, opts, ...) end - _588_ = _593_ + _659_ = _660_ else - local _594_ = filename - local _595_ = opts - local function _597_(...) - return utils["fennel-module"].dofile(_594_, _595_, ...) + local function _661_(...) + return utils["fennel-module"].dofile(filename, opts, ...) end - _588_ = _597_ + _659_ = _661_ end - return _588_, filename - else - return nil + return _659_, filename end end local function lua_macro_searcher(module_name) - local _600_ = search_module(module_name, package.path) - if (nil ~= _600_) then - local filename = _600_ - local code + local _664_0 = search_module(module_name, package.path) + if (nil ~= _664_0) then + local filename = _664_0 + local code = nil do local f = io.open(filename) - local function close_handlers_8_auto(ok_9_auto, ...) + local function close_handlers_10_(ok_11_, ...) f:close() - if ok_9_auto then + if ok_11_ then return ... else return error(..., 0) end end - local function _602_() + local function _666_() return assert(f:read("*a")) end - code = close_handlers_8_auto(_G.xpcall(_602_, (package.loaded.fennel or debug).traceback)) + code = close_handlers_10_(_G.xpcall(_666_, (package.loaded.fennel or debug).traceback)) end local chunk = load_code(code, make_compiler_env(), filename) return chunk, filename - else - return nil end end local macro_searchers = {fennel_macro_searcher, lua_macro_searcher} local function search_macro_module(modname, n) - local _604_ = macro_searchers[n] - if (nil ~= _604_) then - local f = _604_ - local _605_, _606_ = f(modname) - if ((nil ~= _605_) and true) then - local loader = _605_ - local _3ffilename = _606_ + local _668_0 = macro_searchers[n] + if (nil ~= _668_0) then + local f = _668_0 + local _669_0, _670_0 = f(modname) + if ((nil ~= _669_0) and true) then + local loader = _669_0 + local _3ffilename = _670_0 return loader, _3ffilename - elseif true then - local _ = _605_ - return search_macro_module(modname, (n + 1)) else - return nil + local _ = _669_0 + return search_macro_module(modname, (n + 1)) end - else - return nil end end local function sandbox_fennel_module(modname) if ((modname == "fennel.macros") or (package and package.loaded and ("table" == type(package.loaded[modname])) and (package.loaded[modname].metadata == compiler.metadata))) then - return {metadata = compiler.metadata, view = view} - else - return nil + local function _673_(_, ...) + return (compiler.metadata):setall(...) + end + return {metadata = {setall = _673_}, view = view} end end - local function _610_(modname) - local function _611_() + local function _675_(modname) + local function _676_() local loader, filename = search_macro_module(modname, 1) compiler.assert(loader, (modname .. " module not found.")) - do end (macro_loaded)[modname] = loader(modname, filename) + macro_loaded[modname] = loader(modname, filename) return macro_loaded[modname] end - return (macro_loaded[modname] or sandbox_fennel_module(modname) or _611_()) + return (macro_loaded[modname] or sandbox_fennel_module(modname) or _676_()) end - safe_require = _610_ + safe_require = _675_ 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 compiler.assert((type(v) == "function"), "expected each macro to be function", ast) compiler["check-binding-valid"](utils.sym(k), scope, ast, {["macro?"] = true}) - do end (scope.macros)[k] = v + scope.macros[k] = v end return nil end - local function resolve_module_name(_612_, _scope, _parent, opts) - local _arg_613_ = _612_ - local filename = _arg_613_["filename"] - local second = _arg_613_[2] + local function resolve_module_name(_677_0, _scope, _parent, opts) + local _678_ = _677_0 + local second = _678_[2] + local filename = _678_["filename"] local filename0 = (filename or (utils["table?"](second) and second.filename)) local module_name = utils.root.options["module-name"] local modexpr = compiler.compile(second, opts) @@ -2385,28 +2593,26 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct if not macro_loaded[modname] then local loader, filename = search_macro_module(modname, 1) compiler.assert(loader, (modname .. " module not found."), ast) - do end (macro_loaded)[modname] = compiler.assert(utils["table?"](loader(modname, filename)), "expected macros to be table", (_3freal_ast or ast)) - else + macro_loaded[modname] = compiler.assert(utils["table?"](loader(modname, filename)), "expected macros to be table", (_3freal_ast or ast)) end - if ("import-macros" == tostring(ast[1])) then + if ("import-macros" == str1(ast)) then return macro_loaded[modname] else - return add_macros(macro_loaded[modname], ast, scope, parent) + return add_macros(macro_loaded[modname], ast, scope) end end - doc_special("require-macros", {"macro-module-name"}, "Load given module and use its contents as macro definitions in current scope.\nMacro module should return a table of macro functions with string keys.\nConsider using import-macros instead as it is more flexible.") + doc_special("require-macros", {"macro-module-name"}, "Load given module and use its contents as macro definitions in current scope.\nDeprecated.") local function emit_included_fennel(src, path, opts, sub_chunk) local subscope = compiler["make-scope"](utils.root.scope.parent) local forms = {} if utils.root.options.requireAsInclude then subscope.specials.require = compiler["require-include"] - else end for _, val in parser.parser(parser["string-stream"](src), path) do table.insert(forms, val) end for i = 1, #forms do - local subopts + local subopts = nil if (i == #forms) then subopts = {tail = true} else @@ -2419,21 +2625,21 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end local function include_path(ast, opts, path, mod, fennel_3f) utils.root.scope.includes[mod] = "fnl/loading" - local src + local src = nil do local f = assert(io.open(path)) - local function close_handlers_8_auto(ok_9_auto, ...) + local function close_handlers_10_(ok_11_, ...) f:close() - if ok_9_auto then + if ok_11_ then return ... else return error(..., 0) end end - local function _619_() + local function _684_() return assert(f:read("*all")):gsub("[\13\n]*$", "") end - src = close_handlers_8_auto(_G.xpcall(_619_, (package.loaded.fennel or debug).traceback)) + src = close_handlers_10_(_G.xpcall(_684_, (package.loaded.fennel or debug).traceback)) end local ret = utils.expr(("require(\"" .. mod .. "\")"), "statement") local target = ("package.preload[%q]"):format(mod) @@ -2457,23 +2663,19 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct if (utils.root.scope.includes[mod] == "fnl/loading") then compiler.assert(fallback, "circular include detected", ast) return fallback(modexpr) - else - return nil end end SPECIALS.include = function(ast, scope, parent, opts) compiler.assert((#ast == 2), "expected one argument", ast) - local modexpr + local modexpr = nil do - local _622_, _623_ = pcall(resolve_module_name, ast, scope, parent, opts) - if ((_622_ == true) and (nil ~= _623_)) then - local modname = _623_ + local _687_0, _688_0 = pcall(resolve_module_name, ast, scope, parent, opts) + if ((_687_0 == true) and (nil ~= _688_0)) then + local modname = _688_0 modexpr = utils.expr(string.format("%q", modname), "literal") - elseif true then - local _ = _622_ - modexpr = (compiler.compile1(ast[2], scope, parent, {nval = 1}))[1] else - modexpr = nil + local _ = _687_0 + modexpr = compiler.compile1(ast[2], scope, parent, {nval = 1})[1] end end if ((modexpr.type ~= "literal") or ((modexpr[1]):byte() ~= 34)) then @@ -2485,17 +2687,17 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct else local mod = load_code(("return " .. modexpr[1]))() local oldmod = utils.root.options["module-name"] - local _ + local _ = nil utils.root.options["module-name"] = mod _ = nil - local res - local function _627_() - local _626_ = search_module(mod) - if (nil ~= _626_) then - local fennel_path = _626_ + local res = nil + local function _692_() + local _691_0 = search_module(mod) + if (nil ~= _691_0) then + local fennel_path = _691_0 return include_path(ast, opts, fennel_path, mod, true) - elseif true then - local _0 = _626_ + else + local _0 = _691_0 local lua_path = search_module(mod, package.path) if lua_path then return include_path(ast, opts, lua_path, mod, false) @@ -2504,11 +2706,9 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct else return compiler.assert(false, ("module not found " .. mod), ast) end - else - return nil end end - res = ((utils["member?"](mod, (utils.root.options.skipInclude or {})) and opts.fallback(modexpr, true)) or include_circular_fallback(mod, modexpr, opts.fallback, ast) or utils.root.scope.includes[mod] or _627_()) + res = ((utils["member?"](mod, (utils.root.options.skipInclude or {})) and opts.fallback(modexpr, true)) or include_circular_fallback(mod, modexpr, opts.fallback, ast) or utils.root.scope.includes[mod] or _692_()) utils.root.options["module-name"] = oldmod return res end @@ -2519,41 +2719,90 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local opts = utils.copy(utils.root.options) opts.scope = compiler["make-scope"](compiler.scopes.compiler) opts.allowedGlobals = current_global_names(env) - return assert(load_code(compiler.compile(ast, opts), wrap_env(env)), opts["module-name"], ast.filename)() + return assert(load_code(compiler.compile(ast, opts), wrap_env(env)))(opts["module-name"], ast.filename) end SPECIALS.macros = function(ast, scope, parent) - compiler.assert(((#ast == 2) and utils["table?"](ast[2])), "Expected one table argument", ast) - return add_macros(eval_compiler_2a(ast[2], scope, parent), ast, scope, parent) + compiler.assert((#ast == 2), "Expected one table argument", ast) + local macro_tbl = eval_compiler_2a(ast[2], scope, parent) + compiler.assert(utils["table?"](macro_tbl), "Expected one table argument", ast) + return add_macros(macro_tbl, ast, scope) end doc_special("macros", {"{:macro-name-1 (fn [...] ...) ... :macro-name-N macro-body-N}"}, "Define all functions in the given table as macros local to the current scope.") + SPECIALS["tail!"] = function(ast, scope, parent, opts) + compiler.assert((#ast == 2), "Expected one argument", ast) + local call = utils["list?"](compiler.macroexpand(ast[2], scope)) + local callee = tostring((call and utils["sym?"](call[1]))) + compiler.assert((call and not scope.specials[callee]), "Expected a function call as argument", ast) + compiler.assert(opts.tail, "Must be in tail position", ast) + return compiler.compile1(call, scope, parent, opts) + end + doc_special("tail!", {"body"}, "Assert that the body being called is in tail position.") + SPECIALS["pick-values"] = function(ast, scope, parent) + local n = ast[2] + local vals = utils.list(utils.sym("values"), unpack(ast, 3)) + compiler.assert((("number" == type(n)) and (0 <= n) and (n == math.floor(n))), ("Expected n to be an integer >= 0, got " .. tostring(n))) + if (1 == n) then + local _696_ = compiler.compile1(vals, scope, parent, {nval = 1}) + local _697_ = _696_[1] + local expr = _697_[1] + return {("(" .. expr .. ")")} + elseif (0 == n) then + for i = 3, #ast do + compiler["keep-side-effects"](compiler.compile1(ast[i], scope, parent, {nval = 0}), parent, nil, ast[i]) + end + return {} + else + local syms = nil + do + local tbl_17_ = utils.list() + local i_18_ = #tbl_17_ + for _ = 1, n do + local val_19_ = utils.sym(compiler.gensym(scope, "pv")) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end + end + syms = tbl_17_ + end + compiler.destructure(syms, vals, ast, scope, parent, {declaration = true, nomulti = true, noundef = true, symtype = "pv"}) + return syms + end + end + doc_special("pick-values", {"n", "..."}, "Evaluate to exactly n values.\n\nFor example,\n (pick-values 2 ...)\nexpands to\n (let [(_0_ _1_) ...]\n (values _0_ _1_))") SPECIALS["eval-compiler"] = function(ast, scope, parent) local old_first = ast[1] ast[1] = utils.sym("do") local val = eval_compiler_2a(ast, scope, parent) - do end (ast)[1] = old_first + ast[1] = old_first return val end doc_special("eval-compiler", {"..."}, "Evaluate the body at compile-time. Use the macro system instead if possible.", true) - return {doc = doc_2a, ["current-global-names"] = current_global_names, ["load-code"] = load_code, ["macro-loaded"] = macro_loaded, ["macro-searchers"] = macro_searchers, ["make-compiler-env"] = make_compiler_env, ["search-module"] = search_module, ["make-searcher"] = make_searcher, ["wrap-env"] = wrap_env} + SPECIALS.unquote = function(ast) + return compiler.assert(false, "tried to use unquote outside quote", ast) + end + doc_special("unquote", {"..."}, "Evaluate the argument even if it's in a quoted form.") + return {["current-global-names"] = current_global_names, ["get-function-metadata"] = get_function_metadata, ["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") local parser = require("fennel.parser") local friend = require("fennel.friend") + local view = require("fennel.view") local unpack = (table.unpack or _G.unpack) - local scopes = {} + local scopes = {compiler = nil, global = nil, macro = nil} local function make_scope(_3fparent) local parent = (_3fparent or scopes.global) - local _268_ + local _275_ if parent then - _268_ = ((parent.depth or 0) + 1) + _275_ = ((parent.depth or 0) + 1) else - _268_ = 0 + _275_ = 0 end - return {includes = setmetatable({}, {__index = (parent and parent.includes)}), macros = setmetatable({}, {__index = (parent and parent.macros)}), manglings = setmetatable({}, {__index = (parent and parent.manglings)}), specials = setmetatable({}, {__index = (parent and parent.specials)}), symmeta = setmetatable({}, {__index = (parent and parent.symmeta)}), unmanglings = setmetatable({}, {__index = (parent and parent.unmanglings)}), gensyms = setmetatable({}, {__index = (parent and parent.gensyms)}), autogensyms = setmetatable({}, {__index = (parent and parent.autogensyms)}), vararg = (parent and parent.vararg), depth = _268_, hashfn = (parent and parent.hashfn), refedglobals = {}, parent = parent} + return {["gensym-base"] = setmetatable({}, {__index = (parent and parent["gensym-base"])}), autogensyms = setmetatable({}, {__index = (parent and parent.autogensyms)}), depth = _275_, gensyms = setmetatable({}, {__index = (parent and parent.gensyms)}), hashfn = (parent and parent.hashfn), includes = setmetatable({}, {__index = (parent and parent.includes)}), macros = setmetatable({}, {__index = (parent and parent.macros)}), manglings = setmetatable({}, {__index = (parent and parent.manglings)}), parent = parent, refedglobals = {}, specials = setmetatable({}, {__index = (parent and parent.specials)}), symmeta = setmetatable({}, {__index = (parent and parent.symmeta)}), unmanglings = setmetatable({}, {__index = (parent and parent.unmanglings)}), vararg = (parent and parent.vararg)} end local function assert_msg(ast, msg) - local ast_tbl + local ast_tbl = nil if ("table" == type(ast)) then ast_tbl = ast else @@ -2564,15 +2813,15 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local line = ((m and m.line) or ast_tbl.line or "?") local col = ((m and m.col) or ast_tbl.col or "?") local target = tostring((utils["sym?"](ast_tbl[1]) or ast_tbl[1] or "()")) - return string.format("%s:%s:%s Compile error in '%s': %s", filename, line, col, target, msg) + return string.format("%s:%s:%s: Compile error in '%s': %s", filename, line, col, target, msg) end local function assert_compile(condition, msg, ast, _3ffallback_ast) if not condition then - local _let_271_ = (utils.root.options or {}) - local source = _let_271_["source"] - local unfriendly = _let_271_["unfriendly"] - local error_pinpoint = _let_271_["error-pinpoint"] - local ast0 + local _278_ = (utils.root.options or {}) + local error_pinpoint = _278_["error-pinpoint"] + local source = _278_["source"] + local unfriendly = _278_["unfriendly"] + local ast0 = nil if next(utils["ast-source"](ast)) then ast0 = ast else @@ -2580,14 +2829,12 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end if (nil == utils.hook("assert-compile", condition, msg, ast0, utils.root.reset)) then utils.root.reset() - if (unfriendly or not friend or not _G.io or not _G.io.read) then + if unfriendly then error(assert_msg(ast0, msg), 0) else friend["assert-compile"](condition, msg, ast0, source, {["error-pinpoint"] = error_pinpoint}) end - else end - else end return condition end @@ -2595,76 +2842,62 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct scopes.global.vararg = true scopes.compiler = make_scope(scopes.global) scopes.macro = scopes.global - local serialize_subst = {["\7"] = "\\a", ["\8"] = "\\b", ["\9"] = "\\t", ["\n"] = "n", ["\11"] = "\\v", ["\12"] = "\\f"} local function serialize_string(str) - local function _276_(_241) + local function _283_(_241) return ("\\" .. _241:byte()) end - return string.gsub(string.gsub(string.format("%q", str), ".", serialize_subst), "[\128-\255]", _276_) + return string.gsub(string.gsub(string.gsub(string.format("%q", str), "\\\n", "\\n"), "\\9", "\\t"), "[\128-\255]", _283_) end local function global_mangling(str) if utils["valid-lua-identifier?"](str) then return str else - local function _277_(_241) + local function _284_(_241) return string.format("_%02x", _241:byte()) end - return ("__fnl_global__" .. str:gsub("[^%w]", _277_)) + return ("__fnl_global__" .. str:gsub("[^%w]", _284_)) end end local function global_unmangling(identifier) - local _279_ = string.match(identifier, "^__fnl_global__(.*)$") - if (nil ~= _279_) then - local rest = _279_ - local _280_ - local function _281_(_241) + local _286_0 = string.match(identifier, "^__fnl_global__(.*)$") + if (nil ~= _286_0) then + local rest = _286_0 + local _287_0 = nil + local function _288_(_241) return string.char(tonumber(_241:sub(2), 16)) end - _280_ = string.gsub(rest, "_[%da-f][%da-f]", _281_) - return _280_ - elseif true then - local _ = _279_ - return identifier + _287_0 = string.gsub(rest, "_[%da-f][%da-f]", _288_) + return _287_0 else - return nil + local _ = _286_0 + return identifier end end - local allowed_globals = nil local function global_allowed_3f(name) - return (not allowed_globals or utils["member?"](name, allowed_globals)) + local allowed = nil + do + local _290_0 = utils.root.options + if (nil ~= _290_0) then + _290_0 = _290_0.allowedGlobals + end + allowed = _290_0 + end + return (not allowed or utils["member?"](name, allowed)) end local function unique_mangling(original, mangling, scope, append) - if (scope.unmanglings[mangling] and not scope.gensyms[mangling]) then + if scope.unmanglings[mangling] then return unique_mangling(original, (original .. append), scope, (append + 1)) else return mangling end end - local function local_mangling(str, scope, ast, _3ftemp_manglings) - assert_compile(not utils["multi-sym?"](str), ("unexpected multi symbol " .. str), ast) - local raw - if ((utils["lua-keywords"])[str] or str:match("^%d")) then - raw = ("_" .. str) - else - raw = str - end - local mangling - local function _285_(_241) - return string.format("_%02x", _241:byte()) - end - mangling = string.gsub(string.gsub(raw, "-", "_"), "[^%w_]", _285_) - local unique = unique_mangling(mangling, mangling, scope, 0) - do end (scope.unmanglings)[unique] = str - do - local manglings = (_3ftemp_manglings or scope.manglings) - do end (manglings)[str] = unique - end - return unique - end - local function apply_manglings(scope, new_manglings, ast) - for raw, mangled in pairs(new_manglings) do + local function apply_deferred_scope_changes(scope, deferred_scope_changes, ast) + for raw, mangled in pairs(deferred_scope_changes.manglings) do assert_compile(not scope.refedglobals[mangled], ("use of global " .. raw .. " is aliased by a local"), ast) - do end (scope.manglings)[raw] = mangled + scope.manglings[raw] = mangled + end + for raw, symmeta in pairs(deferred_scope_changes.symmeta) do + scope.symmeta[raw] = symmeta end return nil end @@ -2683,17 +2916,23 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end return ret end - local function next_append() - utils.root.scope["gensym-append"] = ((utils.root.scope["gensym-append"] or 0) + 1) - return ("_" .. utils.root.scope["gensym-append"] .. "_") + local function root_scope(scope) + return ((utils.root and utils.root.scope) or (scope.parent and root_scope(scope.parent)) or scope) + end + local function next_append(root_scope_2a) + root_scope_2a["gensym-append"] = ((root_scope_2a["gensym-append"] or 0) + 1) + return ("_" .. root_scope_2a["gensym-append"] .. "_") end local function gensym(scope, _3fbase, _3fsuffix) - local mangling = ((_3fbase or "") .. next_append() .. (_3fsuffix or "")) + local root_scope_2a = root_scope(scope) + local mangling = ((_3fbase or "") .. next_append(root_scope_2a) .. (_3fsuffix or "")) while scope.unmanglings[mangling] do - mangling = ((_3fbase or "") .. next_append() .. (_3fsuffix or "")) + mangling = ((_3fbase or "") .. next_append(root_scope_2a) .. (_3fsuffix or "")) + end + if (_3fbase and (0 < #_3fbase)) then + scope["gensym-base"][mangling] = _3fbase end - scope.unmanglings[mangling] = (_3fbase or true) - do end (scope.gensyms)[mangling] = true + scope.gensyms[mangling] = true return mangling end local function combine_auto_gensym(parts, first) @@ -2705,44 +2944,58 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct return table.concat(parts, ".") end local function autogensym(base, scope) - local _288_ = utils["multi-sym?"](base) - if (nil ~= _288_) then - local parts = _288_ + local _296_0 = utils["multi-sym?"](base) + if (nil ~= _296_0) then + local parts = _296_0 return combine_auto_gensym(parts, autogensym(parts[1], scope)) - elseif true then - local _ = _288_ - local function _289_() - local mangling = gensym(scope, base:sub(1, ( - 2)), "auto") - do end (scope.autogensyms)[base] = mangling + else + local _ = _296_0 + local function _297_() + local mangling = gensym(scope, base:sub(1, -2), "auto") + scope.autogensyms[base] = mangling return mangling end - return (scope.autogensyms[base] or _289_()) - else - return nil + return (scope.autogensyms[base] or _297_()) end end local function check_binding_valid(symbol, scope, ast, _3fopts) local name = tostring(symbol) - local macro_3f + local macro_3f = nil do - local t_291_ = _3fopts - if (nil ~= t_291_) then - t_291_ = (t_291_)["macro?"] - else + local _299_0 = _3fopts + if (nil ~= _299_0) then + _299_0 = _299_0["macro?"] end - macro_3f = t_291_ + macro_3f = _299_0 end - assert_compile(not name:find("&"), "invalid character: &", symbol) + assert_compile(("&" ~= name:match("[&.:]")), "invalid character: &", symbol) assert_compile(not name:find("^%."), "invalid character: .", symbol) assert_compile(not (scope.specials[name] or (not macro_3f and scope.macros[name])), ("local %s was overshadowed by a special form or macro"):format(name), ast) return assert_compile(not utils["quoted?"](symbol), string.format("macro tried to bind %s without gensym", name), symbol) end - local function declare_local(symbol, meta, scope, ast, _3ftemp_manglings) + local function declare_local(symbol, scope, ast, _3fvar_3f, _3fdeferred_scope_changes) check_binding_valid(symbol, scope, ast) - local name = tostring(symbol) - assert_compile(not utils["multi-sym?"](name), ("unexpected multi symbol " .. name), ast) - do end (scope.symmeta)[name] = meta - return local_mangling(name, scope, ast, _3ftemp_manglings) + assert_compile(not utils["multi-sym?"](symbol), ("unexpected multi symbol " .. tostring(symbol)), ast) + local str = tostring(symbol) + local raw = nil + if (utils["lua-keyword?"](str) or str:match("^%d")) then + raw = ("_" .. str) + else + raw = str + end + local mangling = nil + local function _302_(_241) + return string.format("_%02x", _241:byte()) + end + mangling = string.gsub(string.gsub(raw, "-", "_"), "[^%w_]", _302_) + local unique = unique_mangling(mangling, mangling, scope, 0) + scope.unmanglings[unique] = (scope["gensym-base"][str] or str) + do + local target = (_3fdeferred_scope_changes or scope) + target.manglings[str] = unique + target.symmeta[str] = {symbol = symbol, var = _3fvar_3f} + end + return unique end local function hashfn_arg_name(name, multi_sym_parts, scope) if not scope.hashfn then @@ -2752,11 +3005,8 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct elseif multi_sym_parts then if (multi_sym_parts and (multi_sym_parts[1] == "$")) then multi_sym_parts[1] = "$1" - else end return table.concat(multi_sym_parts, ".") - else - return nil end end local function symbol_to_expression(symbol, scope, _3freference_3f) @@ -2769,14 +3019,20 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local local_3f = scope.manglings[parts[1]] if (local_3f and scope.symmeta[parts[1]]) then scope.symmeta[parts[1]]["used"] = true - else + symbol.referent = scope.symmeta[parts[1]].symbol end assert_compile(not scope.macros[parts[1]], "tried to reference a macro without calling it", symbol) assert_compile((not scope.specials[parts[1]] or ("require" == parts[1])), "tried to reference a special form without calling it", symbol) assert_compile((not _3freference_3f or local_3f or ("_ENV" == parts[1]) or global_allowed_3f(parts[1])), ("unknown identifier: " .. tostring(parts[1])), symbol) - if (allowed_globals and not local_3f and scope.parent) then + local function _307_() + local _306_0 = utils.root.options + if (nil ~= _306_0) then + _306_0 = _306_0.allowedGlobals + end + return _306_0 + end + if (_307_() and not local_3f and scope.parent) then scope.parent.refedglobals[parts[1]] = true - else end return utils.expr(combine_parts(parts, scope), etype) end @@ -2801,7 +3057,16 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end return new_chunk else - return utils.map(chunk, peephole) + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for _, x in ipairs(chunk) do + local val_19_ = peephole(x) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end + end + return tbl_17_ end end local function flatten_chunk_correlated(main_chunk, options) @@ -2811,14 +3076,12 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct out[last_line0] = ((out[last_line0] or "") .. " " .. chunk.leaf) else for _, subchunk in ipairs(chunk) do - if (subchunk.leaf or (0 < #subchunk)) then + if (subchunk.leaf or next(subchunk)) then local source = utils["ast-source"](subchunk.ast) if (file == source.filename) then last_line0 = math.max(last_line0, (source.line or 0)) - else end last_line0 = flatten(subchunk, out, last_line0, file) - else end end end @@ -2829,47 +3092,63 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct for i = 1, last do if (out[i] == nil) then out[i] = "" - else end end return table.concat(out, "\n") end local function flatten_chunk(file_sourcemap, chunk, tab, depth) if chunk.leaf then - local _let_303_ = utils["ast-source"](chunk.ast) - local filename = _let_303_["filename"] - local line = _let_303_["line"] - table.insert(file_sourcemap, {filename, line}) + local _317_ = utils["ast-source"](chunk.ast) + local endline = _317_["endline"] + local filename = _317_["filename"] + local line = _317_["line"] + if ("end" == chunk.leaf) then + table.insert(file_sourcemap, {filename, (endline or line)}) + else + table.insert(file_sourcemap, {filename, line}) + end return chunk.leaf else - local tab0 + local tab0 = nil do - local _304_ = tab - if (_304_ == true) then + local _319_0 = tab + if (_319_0 == true) then tab0 = " " - elseif (_304_ == false) then + elseif (_319_0 == false) then tab0 = "" - elseif (_304_ == tab) then - tab0 = tab - elseif (_304_ == nil) then + elseif (nil ~= _319_0) then + local tab1 = _319_0 + tab0 = tab1 + elseif (_319_0 == nil) then tab0 = "" else - tab0 = nil + tab0 = nil end end - local function parter(c) - if (c.leaf or (0 < #c)) then - local sub = flatten_chunk(file_sourcemap, c, tab0, (depth + 1)) - if (0 < depth) then - return (tab0 .. sub:gsub("\n", ("\n" .. tab0))) + local _321_ + do + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for _, c in ipairs(chunk) do + local val_19_ = nil + if (c.leaf or next(c)) then + local sub = flatten_chunk(file_sourcemap, c, tab0, (depth + 1)) + if (0 < depth) then + val_19_ = (tab0 .. sub:gsub("\n", ("\n" .. tab0))) + else + val_19_ = sub + end else - return sub + val_19_ = nil + end + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end - else - return nil end + _321_ = tbl_17_ end - return table.concat(utils.map(chunk, parter), "\n") + return table.concat(_321_, "\n") end end local sourcemap = {} @@ -2883,11 +3162,12 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end local function flatten(chunk, options) local chunk0 = peephole(chunk) + local indent = (options.indent or " ") if options.correlate then return flatten_chunk_correlated(chunk0, options), {} else local file_sourcemap = {} - local src = flatten_chunk(file_sourcemap, chunk0, options.indent, 0) + local src = flatten_chunk(file_sourcemap, chunk0, indent, 0) file_sourcemap.short_src = (options.filename or make_short_src((options.source or src))) if options.filename then file_sourcemap.key = ("@" .. options.filename) @@ -2899,24 +3179,25 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end end local function make_metadata() - local function _312_(self, tgt, key) + local function _329_(self, tgt, _3fkey) if self[tgt] then - return self[tgt][key] - else - return nil + if (nil ~= _3fkey) then + return self[tgt][_3fkey] + else + return self[tgt] + end end end - local function _314_(self, tgt, key, value) + local function _332_(self, tgt, key, value) self[tgt] = (self[tgt] or {}) - do end (self[tgt])[key] = value + self[tgt][key] = value return tgt end - local function _315_(self, tgt, ...) + local function _333_(self, tgt, ...) local kv_len = select("#", ...) local kvs = {...} if ((kv_len % 2) ~= 0) then error("metadata:setall() expected even number of k/v pairs") - else end self[tgt] = (self[tgt] or {}) for i = 1, kv_len, 2 do @@ -2924,27 +3205,38 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end return tgt end - return setmetatable({}, {__index = {get = _312_, set = _314_, setall = _315_}, __mode = "k"}) + return setmetatable({}, {__index = {get = _329_, set = _332_, setall = _333_}, __mode = "k"}) end local function exprs1(exprs) - return table.concat(utils.map(exprs, tostring), ", ") - end - local function keep_side_effects(exprs, chunk, start, ast) - local start0 = (start or 1) - for j = start0, #exprs do - local se = exprs[j] - if ((se.type == "expression") and (se[1] ~= "nil")) then - emit(chunk, string.format("do local _ = %s end", tostring(se)), ast) - elseif (se.type == "statement") then - local code = tostring(se) - local disambiguated + local _335_ + do + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for _, e in ipairs(exprs) do + local val_19_ = tostring(e) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end + end + _335_ = tbl_17_ + end + return table.concat(_335_, ", ") + end + local function keep_side_effects(exprs, chunk, _3fstart, ast) + for j = (_3fstart or 1), #exprs do + local subexp = exprs[j] + if ((subexp.type == "expression") and (subexp[1] ~= "nil")) then + emit(chunk, ("do local _ = %s end"):format(tostring(subexp)), ast) + elseif (subexp.type == "statement") then + local code = tostring(subexp) + local disambiguated = nil if (code:byte() == 40) then disambiguated = ("do end " .. code) else disambiguated = code end emit(chunk, disambiguated, ast) - else end end return nil @@ -2964,47 +3256,42 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct exprs[i] = utils.expr("nil", "literal") end end - else end - else end if opts.tail then emit(parent, string.format("return %s", exprs1(exprs)), ast) - else end if opts.target then local result = exprs1(exprs) - local function _323_() + local function _343_() if (result == "") then return "nil" else return result end end - emit(parent, string.format("%s = %s", opts.target, _323_()), ast) - else + emit(parent, string.format("%s = %s", opts.target, _343_()), ast) end if (opts.tail or opts.target) then return {returned = true} else - local _325_ = exprs - _325_["returned"] = true - return _325_ + exprs["returned"] = true + return exprs end end local function find_macro(ast, scope) - local macro_2a + local macro_2a = nil do - local _327_ = utils["sym?"](ast[1]) - if (_327_ ~= nil) then - local _328_ = tostring(_327_) - if (_328_ ~= nil) then - macro_2a = scope.macros[_328_] + local _346_0 = utils["sym?"](ast[1]) + if (_346_0 ~= nil) then + local _347_0 = tostring(_346_0) + if (_347_0 ~= nil) then + macro_2a = scope.macros[_347_0] else - macro_2a = _328_ + macro_2a = _347_0 end else - macro_2a = _327_ + macro_2a = _346_0 end end local multi_sym_parts = utils["multi-sym?"](ast[1]) @@ -3016,18 +3303,17 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct return macro_2a end end - local function propagate_trace_info(_332_, _index, node) - local _arg_333_ = _332_ - local filename = _arg_333_["filename"] - local line = _arg_333_["line"] - local bytestart = _arg_333_["bytestart"] - local byteend = _arg_333_["byteend"] + local function propagate_trace_info(_351_0, _index, node) + local _352_ = _351_0 + local byteend = _352_["byteend"] + local bytestart = _352_["bytestart"] + local filename = _352_["filename"] + local line = _352_["line"] do local src = utils["ast-source"](node) if (("table" == type(node)) and (filename ~= src.filename)) then src.filename, src.line, src["from-macro?"] = filename, line, true src.bytestart, src.byteend = bytestart, byteend - else end end return ("table" == type(node)) @@ -3035,22 +3321,14 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local function quote_literal_nils(index, node, parent) if (parent and utils["list?"](parent)) then for i = 1, utils.maxn(parent) do - local _335_ = parent[i] - if (_335_ == nil) then + local _354_0 = parent[i] + if (_354_0 == nil) then parent[i] = utils.sym("nil") - else end end - else end return index, node, parent end - local function comp(f, g) - local function _338_(...) - return f(g(...)) - end - return _338_ - end local function built_in_3f(m) local found_3f = false for _, f in pairs(scopes.global.macros) do @@ -3060,64 +3338,58 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct return found_3f end local function macroexpand_2a(ast, scope, _3fonce) - local _339_ + local _357_0 = nil if utils["list?"](ast) then - _339_ = find_macro(ast, scope) + _357_0 = find_macro(ast, scope) else - _339_ = nil + _357_0 = nil end - if (_339_ == false) then + if (_357_0 == false) then return ast - elseif (nil ~= _339_) then - local macro_2a = _339_ + elseif (nil ~= _357_0) then + local macro_2a = _357_0 local old_scope = scopes.macro - local _ + local _ = nil scopes.macro = scope _ = nil local ok, transformed = nil, nil - local function _341_() + local function _359_() return macro_2a(unpack(ast, 2)) end - local function _342_() + local function _360_() if built_in_3f(macro_2a) then return tostring else return debug.traceback end end - ok, transformed = xpcall(_341_, _342_()) - local _344_ - do - local _343_ = ast - local function _345_(...) - return propagate_trace_info(_343_, ...) - end - _344_ = _345_ + ok, transformed = xpcall(_359_, _360_()) + local function _361_(...) + return propagate_trace_info(ast, quote_literal_nils(...)) end - utils["walk-tree"](transformed, comp(_344_, quote_literal_nils)) + utils["walk-tree"](transformed, _361_) scopes.macro = old_scope assert_compile(ok, transformed, ast) + utils.hook("macroexpand", ast, transformed, scope) if (_3fonce or not transformed) then return transformed else return macroexpand_2a(transformed, scope) end - elseif true then - local _ = _339_ - return ast else - return nil + local _ = _357_0 + return ast end end local function compile_special(ast, scope, parent, opts, special) local exprs = (special(ast, scope, parent, opts) or utils.expr("nil", "literal")) - local exprs0 + local exprs0 = nil if ("table" ~= type(exprs)) then exprs0 = utils.expr(exprs, "expression") else exprs0 = exprs end - local exprs2 + local exprs2 = nil if utils["expr?"](exprs0) then exprs2 = {exprs0} else @@ -3131,19 +3403,30 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct return exprs2 end end + local function callable_3f(_367_0, ctype, callee) + local _368_ = _367_0 + local call_ast = _368_[1] + if ("literal" == ctype) then + return ("\"" == string.sub(callee, 1, 1)) + else + return (utils["sym?"](call_ast) or utils["list?"](call_ast)) + end + end local function compile_function_call(ast, scope, parent, opts, compile1, len) + local _370_ = compile1(ast[1], scope, parent, {nval = 1})[1] + local callee = _370_[1] + local ctype = _370_["type"] local fargs = {} - local fcallee = (compile1(ast[1], scope, parent, {nval = 1}))[1] - assert_compile((utils["sym?"](ast[1]) or utils["list?"](ast[1]) or ("string" == type(ast[1]))), ("cannot call literal value " .. tostring(ast[1])), ast) + assert_compile(callable_3f(ast, ctype, callee), ("cannot call literal value " .. tostring(ast[1])), ast) for i = 2, len do - local subexprs - local _351_ + local subexprs = nil + local _371_ if (i ~= len) then - _351_ = 1 + _371_ = 1 else - _351_ = nil + _371_ = nil end - subexprs = compile1(ast[i], scope, parent, {nval = _351_}) + subexprs = compile1(ast[i], scope, parent, {nval = _371_}) table.insert(fargs, subexprs[1]) if (i == len) then for j = 2, #subexprs do @@ -3153,13 +3436,13 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct keep_side_effects(subexprs, parent, 2, ast[i]) end end - local pat - if ("string" == type(ast[1])) then + local pat = nil + if ("literal" == ctype) then pat = "(%s)(%s)" else pat = "%s(%s)" end - local call = string.format(pat, tostring(fcallee), exprs1(fargs)) + local call = string.format(pat, tostring(callee), exprs1(fargs)) return handle_compile_opts({utils.expr(call, "statement")}, parent, opts, ast) end local function compile_call(ast, scope, parent, opts, compile1) @@ -3181,19 +3464,19 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end end local function compile_varg(ast, scope, parent, opts) - local _356_ + local _376_ if scope.hashfn then - _356_ = "use $... in hashfn" + _376_ = "use $... in hashfn" else - _356_ = "unexpected vararg" + _376_ = "unexpected vararg" end - assert_compile(scope.vararg, _356_, ast) + assert_compile(scope.vararg, _376_, ast) return handle_compile_opts({utils.expr("...", "varg")}, parent, opts, ast) end local function compile_sym(ast, scope, parent, opts) local multi_sym_parts = utils["multi-sym?"](ast) assert_compile(not (multi_sym_parts and multi_sym_parts["multi-sym-method-call"]), "multisym method calls may only be in call position", ast) - local e + local e = nil if (ast[1] == "nil") then e = utils.expr("nil", "literal") else @@ -3201,74 +3484,85 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end return handle_compile_opts({e}, parent, opts, ast) end - local function serialize_number(n) - local _359_ = string.gsub(tostring(n), ",", ".") - return _359_ + local view_opts = nil + do + local nan = tostring((0 / 0)) + local _379_ + if (45 == nan:byte()) then + _379_ = "(0/0)" + else + _379_ = "(- (0/0))" + end + local _381_ + if (45 == nan:byte()) then + _381_ = "(- (0/0))" + else + _381_ = "(0/0)" + end + view_opts = {["negative-infinity"] = "(-1/0)", ["negative-nan"] = _379_, infinity = "(1/0)", nan = _381_} end local function compile_scalar(ast, _scope, parent, opts) - local serialize + local compiled = nil do - local _360_ = type(ast) - if (_360_ == "nil") then - serialize = tostring - elseif (_360_ == "boolean") then - serialize = tostring - elseif (_360_ == "string") then - serialize = serialize_string - elseif (_360_ == "number") then - serialize = serialize_number + local _383_0 = type(ast) + if (_383_0 == "nil") then + compiled = "nil" + elseif (_383_0 == "boolean") then + compiled = tostring(ast) + elseif (_383_0 == "string") then + compiled = serialize_string(ast) + elseif (_383_0 == "number") then + compiled = view(ast, view_opts) else - serialize = nil + compiled = nil end end - return handle_compile_opts({utils.expr(serialize(ast), "literal")}, parent, opts) + return handle_compile_opts({utils.expr(compiled, "literal")}, parent, opts) end local function compile_table(ast, scope, parent, opts, compile1) local function escape_key(k) if ((type(k) == "string") and utils["valid-lua-identifier?"](k)) then return k else - local _let_362_ = compile1(k, scope, parent, {nval = 1}) - local compiled = _let_362_[1] + local _385_ = compile1(k, scope, parent, {nval = 1}) + local compiled = _385_[1] return ("[" .. tostring(compiled) .. "]") end end local keys = {} - local buffer + local buffer = nil do - local tbl_16_auto = {} - local i_17_auto = #tbl_16_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ for i, elem in ipairs(ast) do - local val_18_auto + local val_19_ = nil do local nval = ((nil ~= ast[(i + 1)]) and 1) - do end (keys)[i] = true - val_18_auto = exprs1(compile1(elem, scope, parent, {nval = nval})) + keys[i] = true + val_19_ = exprs1(compile1(elem, scope, parent, {nval = nval})) end - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - buffer = tbl_16_auto + buffer = tbl_17_ end do - local tbl_16_auto = buffer - local i_17_auto = #tbl_16_auto - for k, v in utils.stablepairs(ast) do - local val_18_auto + local tbl_17_ = buffer + local i_18_ = #tbl_17_ + for k in utils.stablepairs(ast) do + local val_19_ = nil if not keys[k] then - local _let_365_ = compile1(ast[k], scope, parent, {nval = 1}) - local v0 = _let_365_[1] - val_18_auto = string.format("%s = %s", escape_key(k), tostring(v0)) + local _388_ = compile1(ast[k], scope, parent, {nval = 1}) + local v = _388_[1] + val_19_ = string.format("%s = %s", escape_key(k), tostring(v)) else - val_18_auto = nil + val_19_ = nil end - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end end @@ -3293,58 +3587,82 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end local function destructure(to, from, ast, scope, parent, opts) local opts0 = (opts or {}) - local _let_369_ = opts0 - local isvar = _let_369_["isvar"] - local declaration = _let_369_["declaration"] - local forceglobal = _let_369_["forceglobal"] - local forceset = _let_369_["forceset"] - local symtype = _let_369_["symtype"] + local _392_ = opts0 + local declaration = _392_["declaration"] + local forceglobal = _392_["forceglobal"] + local forceset = _392_["forceset"] + local isvar = _392_["isvar"] + local symtype = _392_["symtype"] local symtype0 = ("_" .. (symtype or "dst")) - local setter + local setter = nil if declaration then setter = "local %s = %s" else setter = "%s = %s" end - local new_manglings = {} - local function getname(symbol, up1) + local deferred_scope_changes = {manglings = {}, symmeta = {}} + local function getname(symbol, ast0) local raw = symbol[1] - assert_compile(not (opts0.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), ast0) if declaration then - return declare_local(symbol, nil, scope, symbol, new_manglings) + return declare_local(symbol, scope, symbol, isvar, deferred_scope_changes) else local parts = (utils["multi-sym?"](raw) or {raw}) - local meta = scope.symmeta[parts[1]] + local _394_ = parts + local first = _394_[1] + local meta = scope.symmeta[first] assert_compile(not raw:find(":"), "cannot set method sym", symbol) 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) - else end - assert_compile((meta or not opts0.noundef or global_allowed_3f(parts[1])), ("expected local " .. parts[1]), symbol) + assert_compile((meta or not opts0.noundef or (scope.hashfn and ("$" == first)) or global_allowed_3f(first)), ("expected local " .. first), symbol) if forceglobal then assert_compile(not scope.symmeta[scope.unmanglings[raw]], ("global " .. raw .. " conflicts with local"), symbol) - do end (scope.manglings)[raw] = global_mangling(raw) - do end (scope.unmanglings)[global_mangling(raw)] = raw - if allowed_globals then - table.insert(allowed_globals, raw) - else + scope.manglings[raw] = global_mangling(raw) + scope.unmanglings[global_mangling(raw)] = raw + local _397_ + do + local _396_0 = utils.root.options + if (nil ~= _396_0) then + _396_0 = _396_0.allowedGlobals + end + _397_ = _396_0 + end + if _397_ then + local _400_ + do + local _399_0 = utils.root.options + if (nil ~= _399_0) then + _399_0 = _399_0.allowedGlobals + end + _400_ = _399_0 + end + table.insert(_400_, raw) end - else end return symbol_to_expression(symbol, scope)[1] end end local function compile_top_target(lvalues) - local inits - local function _375_(_241) - if scope.manglings[_241] then - return _241 - else - return "nil" + local inits = nil + do + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for _, l in ipairs(lvalues) do + local val_19_ = nil + if scope.manglings[l] then + val_19_ = l + else + val_19_ = "nil" + end + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end end + inits = tbl_17_ end - inits = utils.map(lvalues, _375_) local init = table.concat(inits, ", ") local lvalue = table.concat(lvalues, ", ") local plast = parent[#parent] @@ -3354,7 +3672,6 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct for pi = plen, #parent do if (parent[pi] == plast) then plen = pi - else end end if ((#parent == (plen + 1)) and parent[#parent].leaf) then @@ -3364,7 +3681,6 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct else table.insert(parent, (plen + 1), {ast = ast, leaf = ("local " .. lvalue .. " = " .. init)}) end - else end return ret end @@ -3372,35 +3688,83 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local lname = getname(left, up1) check_binding_valid(left, scope, left) if top_3f then - compile_top_target({lname}) + return compile_top_target({lname}) else - emit(parent, setter:format(lname, exprs1(rightexprs)), left) + return emit(parent, setter:format(lname, exprs1(rightexprs)), left) end - if declaration then - scope.symmeta[tostring(left)] = {var = isvar} - return nil - else - return nil + end + local function dynamic_set_target(_411_0) + local _412_ = _411_0 + local _ = _412_[1] + local target = _412_[2] + local keys = {(table.unpack or unpack)(_412_, 3)} + assert_compile(utils["sym?"](target), "dynamic set needs symbol target", ast) + assert_compile(next(keys), "dynamic set needs at least one key", ast) + local keys0 = nil + do + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for _0, k in ipairs(keys) do + local val_19_ = tostring(compile1(k, scope, parent, {nval = 1})[1]) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end + end + keys0 = tbl_17_ end + return string.format("%s[%s]", tostring(symbol_to_expression(target, scope, true)), table.concat(keys0, "][")) + end + local function destructure_values(left, rightexprs, up1, destructure1, top_3f) + local left_names, tables = {}, {} + for i, name in ipairs(left) do + if utils["sym?"](name) then + table.insert(left_names, getname(name, up1)) + elseif utils["call-of?"](name, ".") then + table.insert(left_names, dynamic_set_target(name)) + else + local symname = gensym(scope, symtype0) + table.insert(left_names, symname) + tables[i] = {name, utils.expr(symname, "sym")} + end + end + assert_compile(left[1], "must provide at least one value", left) + if top_3f then + compile_top_target(left_names) + elseif utils["expr?"](rightexprs) then + emit(parent, setter:format(table.concat(left_names, ","), exprs1(rightexprs)), left) + else + local names = table.concat(left_names, ",") + local target = nil + if declaration then + target = ("local " .. names) + else + target = names + end + emit(parent, compile1(rightexprs, scope, parent, {target = target}), left) + end + for _, pair in utils.stablepairs(tables) do + destructure1(pair[1], {pair[2]}, left) + end + return nil end local unpack_fn = "function (t, k, e)\n local mt = getmetatable(t)\n if 'table' == type(mt) and mt.__fennelrest then\n return mt.__fennelrest(t, k)\n elseif e then\n local rest = {}\n for k, v in pairs(t) do\n if not e[k] then rest[k] = v end\n end\n return rest\n else\n return {(table.unpack or unpack)(t, k)}\n end\n end" local function destructure_kv_rest(s, v, left, excluded_keys, destructure1) - local exclude_str - local _382_ + local exclude_str = nil + local _417_ do - local tbl_16_auto = {} - local i_17_auto = #tbl_16_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ for _, k in ipairs(excluded_keys) do - local val_18_auto = string.format("[%s] = true", serialize_string(k)) - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + local val_19_ = string.format("[%s] = true", serialize_string(k)) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - _382_ = tbl_16_auto + _417_ = tbl_17_ end - exclude_str = table.concat(_382_, ", ") + exclude_str = table.concat(_417_, ", ") local subexpr = utils.expr(string.format(string.gsub(("(" .. unpack_fn .. ")(%s, %s, {%s})"), "\n%s*", " "), s, tostring(v), exclude_str), "expression") return destructure1(v, {subexpr}, left) end @@ -3408,184 +3772,181 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local unpack_str = ("(" .. unpack_fn .. ")(%s, %s)") local formatted = string.format(string.gsub(unpack_str, "\n%s*", " "), s, k) local subexpr = utils.expr(formatted, "expression") - assert_compile((utils["sequence?"](left) and (nil == left[(k + 2)])), "expected rest argument before last parameter", left) + local function _419_() + local next_symbol = left[(k + 2)] + return ((nil == next_symbol) or utils["sym?"](next_symbol, "&as")) + end + assert_compile((utils["sequence?"](left) and _419_()), "expected rest argument before last parameter", left) return destructure1(left[(k + 1)], {subexpr}, left) end - local function destructure_table(left, rightexprs, top_3f, destructure1) - local s = gensym(scope, symtype0) - local right - do - local _384_ - if top_3f then - _384_ = exprs1(compile1(from, scope, parent)) - else - _384_ = exprs1(rightexprs) - end - if (_384_ == "") then - right = "nil" - elseif (nil ~= _384_) then - local right0 = _384_ - right = right0 - else - right = nil + local function optimize_table_destructure_3f(left, right) + local function _420_() + local all = next(left) + for _, d in ipairs(left) do + if not all then break end + all = ((utils["sym?"](d) and not tostring(d):find("^&")) or (utils["list?"](d) and utils["sym?"](d[1], "."))) end + return all end - local excluded_keys = {} - emit(parent, string.format("local %s = %s", s, right), left) - for k, v in utils.stablepairs(left) do - if not (("number" == type(k)) and tostring(left[(k - 1)]):find("^&")) then - if (utils["sym?"](k) and (tostring(k) == "&")) then - destructure_kv_rest(s, v, left, excluded_keys, destructure1) - elseif (utils["sym?"](v) and (tostring(v) == "&")) then - destructure_rest(s, k, left, destructure1) - elseif (utils["sym?"](k) and (tostring(k) == "&as")) then - destructure_sym(v, {utils.expr(tostring(s))}, left) - elseif (utils["sequence?"](left) and (tostring(v) == "&as")) then - local _, next_sym, trailing = select(k, unpack(left)) - assert_compile((nil == trailing), "expected &as argument before last parameter", left) - destructure_sym(next_sym, {utils.expr(tostring(s))}, left) + return (utils["sequence?"](left) and utils["sequence?"](right) and _420_()) + end + local function destructure_table(left, rightexprs, top_3f, destructure1, up1) + if optimize_table_destructure_3f(left, rightexprs) then + return destructure_values(utils.list(unpack(left)), utils.list(utils.sym("values"), unpack(rightexprs)), up1, destructure1) + else + local right = nil + do + local _421_0 = nil + if top_3f then + _421_0 = exprs1(compile1(from, scope, parent)) else - local key - if (type(k) == "string") then - key = serialize_string(k) - else - key = k - end - local subexpr = utils.expr(string.format("%s[%s]", s, key), "expression") - if (type(k) == "string") then - table.insert(excluded_keys, k) - else - end - destructure1(v, {subexpr}, left) + _421_0 = exprs1(rightexprs) + end + if (_421_0 == "") then + right = "nil" + elseif (nil ~= _421_0) then + local right0 = _421_0 + right = right0 + else + right = nil end - else end - end - return nil - end - local function destructure_values(left, up1, top_3f, destructure1) - local left_names, tables = {}, {} - for i, name in ipairs(left) do - if utils["sym?"](name) then - table.insert(left_names, getname(name, up1)) + local s = nil + if utils["sym?"](rightexprs) then + s = right else - local symname = gensym(scope, symtype0) - table.insert(left_names, symname) - do end (tables)[i] = {name, utils.expr(symname, "sym")} - end - end - assert_compile(left[1], "must provide at least one value", left) - assert_compile(top_3f, "can't nest multi-value destructuring", left) - compile_top_target(left_names) - if declaration then - for _, sym in ipairs(left) do - if utils["sym?"](sym) then - scope.symmeta[tostring(sym)] = {var = isvar} - else + s = gensym(scope, symtype0) + end + local excluded_keys = {} + if not utils["sym?"](rightexprs) then + emit(parent, string.format("local %s = %s", s, right), left) + end + for k, v in utils.stablepairs(left) do + if not (("number" == type(k)) and tostring(left[(k - 1)]):find("^&")) then + if (utils["sym?"](k) and (tostring(k) == "&")) then + destructure_kv_rest(s, v, left, excluded_keys, destructure1) + elseif (utils["sym?"](v) and (tostring(v) == "&")) then + destructure_rest(s, k, left, destructure1) + elseif (utils["sym?"](k) and (tostring(k) == "&as")) then + destructure_sym(v, {utils.expr(tostring(s))}, left) + elseif (utils["sequence?"](left) and (tostring(v) == "&as")) then + local _, next_sym, trailing = select(k, unpack(left)) + assert_compile((nil == trailing), "expected &as argument before last parameter", left) + destructure_sym(next_sym, {utils.expr(tostring(s))}, left) + else + local key = nil + if (type(k) == "string") then + key = serialize_string(k) + else + key = k + end + local subexpr = utils.expr(("%s[%s]"):format(s, key), "expression") + if (type(k) == "string") then + table.insert(excluded_keys, k) + end + destructure1(v, subexpr, left) + end end end - else - end - for _, pair in utils.stablepairs(tables) do - destructure1(pair[1], {pair[2]}, left) + return nil end - return nil end local function destructure1(left, rightexprs, up1, top_3f) if (utils["sym?"](left) and (left[1] ~= "nil")) then destructure_sym(left, rightexprs, up1, top_3f) elseif utils["table?"](left) then - destructure_table(left, rightexprs, top_3f, destructure1) + destructure_table(left, rightexprs, top_3f, destructure1, up1) + elseif utils["call-of?"](left, ".") then + destructure_values({left}, rightexprs, up1, destructure1) elseif utils["list?"](left) then - destructure_values(left, up1, top_3f, destructure1) - else - assert_compile(false, string.format("unable to bind %s %s", type(left), tostring(left)), (((type((up1)[2]) == "table") and (up1)[2]) or up1)) - end - if top_3f then - return {returned = true} + assert_compile(top_3f, "can't nest multi-value destructuring", left) + destructure_values(left, rightexprs, up1, destructure1, true) else - return nil + assert_compile(false, string.format("unable to bind %s %s", type(left), tostring(left)), (((type(up1[2]) == "table") and up1[2]) or up1)) end + return (top_3f and {returned = true}) end - local ret = destructure1(to, nil, ast, true) + local ret = destructure1(to, from, ast, true) utils.hook("destructure", from, to, scope, opts0) - apply_manglings(scope, new_manglings, ast) + apply_deferred_scope_changes(scope, deferred_scope_changes, ast) return ret end local function require_include(ast, scope, parent, opts) opts.fallback = function(e, no_warn) - if (not no_warn and ("literal" == e.type)) then - utils.warn(("include module not found, falling back to require: %s"):format(tostring(e))) - else + if not no_warn then + utils.warn(("include module not found, falling back to require: %s"):format(tostring(e)), ast) end return utils.expr(string.format("require(%s)", tostring(e)), "statement") end return scopes.global.specials.include(ast, scope, parent, opts) end - local function compile_stream(strm, options) + local function compile_asts(asts, options) local opts = utils.copy(options) - local old_globals = allowed_globals local scope = (opts.scope or make_scope(scopes.global)) - local vals = {} local chunk = {} - do end (function(tgt, m, ...) return tgt[m](tgt, ...) end)(utils.root, "set-reset") - allowed_globals = opts.allowedGlobals - if (opts.indent == nil) then - opts.indent = " " - else - end if opts.requireAsInclude then scope.specials.require = require_include - else end + if opts.assertAsRepl then + scope.macros.assert = scope.macros["assert-repl"] + end + local _435_ = utils.root + _435_["set-reset"](_435_) utils.root.chunk, utils.root.scope, utils.root.options = chunk, scope, opts - for _, val in parser.parser(strm, opts.filename, opts) do - table.insert(vals, val) - end - for i = 1, #vals do - local exprs = compile1(vals[i], scope, chunk, {nval = (((i < #vals) and 0) or nil), tail = (i == #vals)}) - keep_side_effects(exprs, chunk, nil, vals[i]) - if (i == #vals) then - utils.hook("chunk", vals[i], scope) - else + for i = 1, #asts do + local exprs = compile1(asts[i], scope, chunk, {nval = (((i < #asts) and 0) or nil), tail = (i == #asts)}) + keep_side_effects(exprs, chunk, nil, asts[i]) + if (i == #asts) then + utils.hook("chunk", asts[i], scope) end end - allowed_globals = old_globals utils.root.reset() return flatten(chunk, opts) end - local function compile_string(str, _3fopts) + local function compile_stream(stream, _3fopts) local opts = (_3fopts or {}) - return compile_stream(parser["string-stream"](str, opts), opts) - end - local function compile(ast, opts) - local opts0 = utils.copy(opts) - local old_globals = allowed_globals - local chunk = {} - local scope = (opts0.scope or make_scope(scopes.global)) - do end (function(tgt, m, ...) return tgt[m](tgt, ...) end)(utils.root, "set-reset") - allowed_globals = opts0.allowedGlobals - if (opts0.indent == nil) then - opts0.indent = " " - else + local asts = nil + do + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for _, ast in parser.parser(stream, opts.filename, opts) do + local val_19_ = ast + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end + end + asts = tbl_17_ end - if opts0.requireAsInclude then - scope.specials.require = require_include + return compile_asts(asts, opts) + end + local function compile_string(str, _3fopts) + return compile_stream(parser["string-stream"](str, _3fopts), _3fopts) + end + local function compile(from, _3fopts) + local _438_0 = type(from) + if (_438_0 == "userdata") then + local function _439_() + local _440_0 = from:read(1) + if (nil ~= _440_0) then + return _440_0:byte() + else + return _440_0 + end + end + return compile_stream(_439_, _3fopts) + elseif (_438_0 == "function") then + return compile_stream(from, _3fopts) else + local _ = _438_0 + return compile_asts({from}, _3fopts) end - utils.root.chunk, utils.root.scope, utils.root.options = chunk, scope, opts0 - local exprs = compile1(ast, scope, chunk, {tail = true}) - keep_side_effects(exprs, chunk, nil, ast) - utils.hook("chunk", ast, scope) - allowed_globals = old_globals - utils.root.reset() - return flatten(chunk, opts0) end local function traceback_frame(info) if ((info.what == "C") and info.name) then - return string.format(" [C]: in function '%s'", info.name) + return string.format("\9[C]: in function '%s'", info.name) elseif (info.what == "C") then - return " [C]: in ?" + return "\9[C]: in ?" else local remap = sourcemap[info.source] if (remap and remap[info.currentline]) then @@ -3595,63 +3956,100 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct info.short_src = remap.short_src end info.currentline = (remap[info.currentline][2] or -1) - else end if (info.what == "Lua") then - local function _404_() + local function _445_() if info.name then return ("'" .. info.name .. "'") else return "?" end end - return string.format(" %s:%d: in function %s", info.short_src, info.currentline, _404_()) + return string.format("\9%s:%d: in function %s", info.short_src, info.currentline, _445_()) elseif (info.short_src == "(tail call)") then return " (tail call)" else - return string.format(" %s:%d: in main chunk", info.short_src, info.currentline) + return string.format("\9%s:%d: in main chunk", info.short_src, info.currentline) end end end + local lua_getinfo = debug.getinfo local function traceback(_3fmsg, _3fstart) - local msg = tostring((_3fmsg or "")) - if ((msg:find("^%g+:%d+:%d+ Compile error:.*") or msg:find("^%g+:%d+:%d+ Parse error:.*")) and not utils["debug-on?"]("trace")) then - return msg - else - local lines = {} - if (msg:find("^%g+:%d+:%d+ Compile error:") or msg:find("^%g+:%d+:%d+ Parse error:")) then - table.insert(lines, msg) - else - local newmsg = msg:gsub("^[^:]*:%d+:%s+", "runtime error: ") - table.insert(lines, newmsg) - end - table.insert(lines, "stack traceback:") - local done_3f, level = false, (_3fstart or 2) - while not done_3f do - do - local _408_ = debug.getinfo(level, "Sln") - if (_408_ == nil) then - done_3f = true - elseif (nil ~= _408_) then - local info = _408_ - table.insert(lines, traceback_frame(info)) - else + local _448_0 = type(_3fmsg) + if ((_448_0 == "nil") or (_448_0 == "string")) then + local msg = (_3fmsg or "") + if ((msg:find("^%g+:%d+:%d+ Compile error:.*") or msg:find("^%g+:%d+:%d+ Parse error:.*")) and not utils["debug-on?"]("trace")) then + return msg + else + local lines = {} + if (msg:find("^%g+:%d+:%d+ Compile error:") or msg:find("^%g+:%d+:%d+ Parse error:")) then + table.insert(lines, msg) + else + local newmsg = msg:gsub("^[^:]*:%d+:%s+", "runtime error: ") + table.insert(lines, newmsg) + end + table.insert(lines, "stack traceback:") + local done_3f, level = false, (_3fstart or 2) + while not done_3f do + do + local _450_0 = lua_getinfo(level, "Sln") + if (_450_0 == nil) then + done_3f = true + elseif (nil ~= _450_0) then + local info = _450_0 + table.insert(lines, traceback_frame(info)) + end end + level = (level + 1) end - level = (level + 1) + return table.concat(lines, "\n") end - return table.concat(lines, "\n") + else + local _ = _448_0 + return _3fmsg end end - local function entry_transform(fk, fv) - local function _411_(k, v) - if (type(k) == "number") then - return k, fv(v) - else - return fk(k), fv(v) + local function getinfo(thread_or_level, ...) + local thread_or_level0 = nil + if ("number" == type(thread_or_level)) then + thread_or_level0 = (1 + thread_or_level) + else + thread_or_level0 = thread_or_level + end + local info = lua_getinfo(thread_or_level0, ...) + local mapped = (info and sourcemap[info.source]) + if mapped then + for _, key in ipairs({"currentline", "linedefined", "lastlinedefined"}) do + local mapped_value = nil + do + local _455_0 = mapped + if (nil ~= _455_0) then + _455_0 = _455_0[info[key]] + end + if (nil ~= _455_0) then + _455_0 = _455_0[2] + end + mapped_value = _455_0 + end + if (info[key] and mapped_value) then + info[key] = mapped_value + end + end + if info.activelines then + local tbl_14_ = {} + for line in pairs(info.activelines) do + local k_15_, v_16_ = mapped[line][2], true + if ((k_15_ ~= nil) and (v_16_ ~= nil)) then + tbl_14_[k_15_] = v_16_ + end + end + info.activelines = tbl_14_ + end + if (info.what == "Lua") then + info.what = "Fennel" end end - return _411_ + return info end local function mixed_concat(t, joiner) local seen = {} @@ -3665,20 +4063,33 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct if not seen[k] then ret = (ret .. s .. "[" .. k .. "]" .. "=" .. v) s = joiner - else end end return ret end local function do_quote(form, scope, parent, runtime_3f) - local function q(x) - return do_quote(x, scope, parent, runtime_3f) + local function quote_all(form0, discard_non_numbers) + local tbl_14_ = {} + for k, v in utils.stablepairs(form0) do + local k_15_, v_16_ = nil, nil + if (type(k) == "number") then + k_15_, v_16_ = k, do_quote(v, scope, parent, runtime_3f) + elseif not discard_non_numbers then + k_15_, v_16_ = do_quote(k, scope, parent, runtime_3f), do_quote(v, scope, parent, runtime_3f) + else + k_15_, v_16_ = nil + end + if ((k_15_ ~= nil) and (v_16_ ~= nil)) then + tbl_14_[k_15_] = v_16_ + end + end + return tbl_14_ end if utils["varg?"](form) then assert_compile(not runtime_3f, "quoted ... may only be used at compile time", form) return "_VARARG" elseif utils["sym?"](form) then - local filename + local filename = nil if form.filename then filename = string.format("%q", form.filename) else @@ -3687,93 +4098,87 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local symstr = tostring(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', {filename=%s, line=%s})", autogensym(symstr, scope), filename, (form.line or "nil")) + return string.format("_G.sym('%s', {filename=%s, line=%s})", autogensym(symstr, scope), filename, (form.line or "nil")) else - return string.format("sym('%s', {quoted=true, filename=%s, line=%s})", symstr, filename, (form.line or "nil")) + return string.format("_G.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 (tostring(form[1]) == "unquote")) then - local payload = form[2] - local res = unpack(compile1(payload, scope, parent)) + elseif utils["call-of?"](form, "unquote") then + local res = unpack(compile1(form[2], scope, parent)) return res[1] elseif utils["list?"](form) then - local mapped - local function _416_() - return nil - end - mapped = utils.kvmap(form, entry_transform(_416_, q)) - local filename + local mapped = quote_all(form, true) + local filename = nil if form.filename then filename = string.format("%q", form.filename) else filename = "nil" 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, ", ")) + return string.format(("setmetatable({filename=%s, line=%s, bytestart=%s, %s}" .. ", getmetatable(_G.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 mapped = quote_all(form) local source = getmetatable(form) - local filename + local filename = nil if source.filename then filename = string.format("%q", source.filename) else filename = "nil" end - local _419_ + local _470_ if source then - _419_ = source.line + _470_ = source.line else - _419_ = "nil" + _470_ = "nil" end - return string.format("setmetatable({%s}, {filename=%s, line=%s, sequence=%s})", mixed_concat(mapped, ", "), filename, _419_, "(getmetatable(sequence()))['sequence']") + return string.format("setmetatable({%s}, {filename=%s, line=%s, sequence=%s})", mixed_concat(mapped, ", "), filename, _470_, "(getmetatable(_G.sequence()))['sequence']") elseif (type(form) == "table") then - local mapped = utils.kvmap(form, entry_transform(q, q)) + local mapped = quote_all(form) local source = getmetatable(form) - local filename + local filename = nil if source.filename then filename = string.format("%q", source.filename) else filename = "nil" end - local function _422_() + local function _473_() if source then return source.line else return "nil" end end - return string.format("setmetatable({%s}, {filename=%s, line=%s})", mixed_concat(mapped, ", "), filename, _422_()) + return string.format("setmetatable({%s}, {filename=%s, line=%s})", mixed_concat(mapped, ", "), filename, _473_()) elseif (type(form) == "string") then return serialize_string(form) else return tostring(form) end end - return {compile = compile, compile1 = compile1, ["compile-stream"] = compile_stream, ["compile-string"] = compile_string, ["check-binding-valid"] = check_binding_valid, emit = emit, destructure = destructure, ["require-include"] = require_include, autogensym = autogensym, gensym = gensym, ["do-quote"] = do_quote, ["global-mangling"] = global_mangling, ["global-unmangling"] = global_unmangling, ["apply-manglings"] = apply_manglings, macroexpand = macroexpand_2a, ["declare-local"] = declare_local, ["make-scope"] = make_scope, ["keep-side-effects"] = keep_side_effects, ["symbol-to-expression"] = symbol_to_expression, assert = assert_compile, scopes = scopes, traceback = traceback, metadata = make_metadata(), sourcemap = sourcemap} + return {["apply-deferred-scope-changes"] = apply_deferred_scope_changes, ["check-binding-valid"] = check_binding_valid, ["compile-stream"] = compile_stream, ["compile-string"] = compile_string, ["declare-local"] = declare_local, ["do-quote"] = do_quote, ["global-allowed?"] = global_allowed_3f, ["global-mangling"] = global_mangling, ["global-unmangling"] = global_unmangling, ["keep-side-effects"] = keep_side_effects, ["make-scope"] = make_scope, ["require-include"] = require_include, ["symbol-to-expression"] = symbol_to_expression, assert = assert_compile, autogensym = autogensym, compile = compile, compile1 = compile1, destructure = destructure, emit = emit, gensym = gensym, getinfo = getinfo, macroexpand = macroexpand_2a, metadata = make_metadata(), scopes = scopes, sourcemap = sourcemap, traceback = traceback} end package.preload["fennel.friend"] = package.preload["fennel.friend"] or function(...) local utils = require("fennel.utils") local utf8_ok_3f, utf8 = pcall(require, "utf8") - local suggestions = {["unexpected multi symbol (.*)"] = {"removing periods or colons from %s"}, ["use of global (.*) is aliased by a local"] = {"renaming local %s", "refer to the global using _G.%s instead of directly"}, ["local (.*) was overshadowed by a special form or macro"] = {"renaming local %s"}, ["global (.*) conflicts with local"] = {"renaming local %s"}, ["expected var (.*)"] = {"declaring %s using var instead of let/local", "introducing a new local instead of changing the value of %s"}, ["expected macros to be table"] = {"ensuring your macro definitions return a table"}, ["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"}, ["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"}, ["unknown identifier: (.*)"] = {"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"}, ["expected a function.* to call"] = {"removing the empty parentheses", "using square brackets if you want an empty table"}, ["cannot call literal value"] = {"checking for typos", "checking for a missing function name", "making sure to use prefix operators, not infix"}, ["unexpected vararg"] = {"putting \"...\" at the end of the fn parameters if the vararg was intended"}, ["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"}, ["unused local (.*)"] = {"renaming the local to _%s if it is meant to be unused", "fixing a typo so %s is used", "disabling the linter which checks for unused locals"}, ["expected parameters"] = {"adding function parameters as a list of identifiers in brackets"}, ["unable to bind (.*)"] = {"replacing the %s with an identifier"}, ["expected rest argument before last parameter"] = {"moving & to right before the final identifier when destructuring"}, ["expected vararg as last parameter"] = {"moving the \"...\" to the end of the parameter list"}, ["expected symbol for function parameter: (.*)"] = {"changing %s to an identifier instead of a literal value"}, ["could not compile value of type "] = {"debugging the macro you're calling to return a list or table"}, ["expected local"] = {"looking for a typo", "looking for a local which is used out of its scope"}, ["expected body expression"] = {"putting some code in the body of this form after the bindings"}, ["expected binding and iterator"] = {"making sure you haven't omitted a local name or iterator"}, ["expected binding sequence"] = {"placing a table here in square brackets containing identifiers to bind"}, ["expected even number of name/value bindings"] = {"finding where the identifier or value is missing"}, ["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"}, ["unexpected closing delimiter (.)"] = {"deleting %s", "adding matching opening delimiter earlier"}, ["mismatched closing delimiter (.), expected (.)"] = {"replacing %s with %s", "deleting %s", "adding matching opening delimiter earlier"}, ["expected even number of values in table literal"] = {"removing a key", "adding a value"}, ["expected whitespace before opening delimiter"] = {"adding whitespace"}, ["invalid character: (.)"] = {"deleting or replacing %s", "avoiding reserved characters like \", \\, ', ~, ;, @, `, and comma"}, ["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"}, ["can't start multisym segment with a digit"] = {"removing the digit", "adding a non-digit before the digit"}, ["malformed multisym"] = {"ensuring each period or colon is not followed by another period or colon"}, ["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"}, ["$ and $... in hashfn are mutually exclusive"] = {"modifying the hashfn so it only contains $... or $, $1, $2, $3, etc"}, ["tried to reference a macro without calling it"] = {"renaming the macro so as not to conflict with locals"}, ["tried to reference a special form without calling it"] = {"making sure to use prefix operators, not infix", "wrapping the special in a function if you need it to be first class"}, ["missing subject"] = {"adding an item to operate on"}, ["expected even number of pattern/body pairs"] = {"checking that every pattern has a body to go with it", "adding _ before the final body"}, ["expected at least one pattern/body pair"] = {"adding a pattern and a body to execute when the pattern matches"}, ["unexpected arguments"] = {"removing an argument", "checking for typos"}, ["unexpected iterator clause"] = {"removing an argument", "checking for typos"}} + local suggestions = {["$ and $... in hashfn are mutually exclusive"] = {"modifying the hashfn so it only contains $... or $, $1, $2, $3, etc"}, ["can't introduce (.*) here"] = {"declaring the local at the top-level"}, ["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", "making sure to use prefix operators, not infix"}, ["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 at least one pattern/body pair"] = {"adding a pattern and a body to execute when the pattern matches"}, ["expected binding and iterator"] = {"making sure you haven't omitted a local name or iterator"}, ["expected binding sequence"] = {"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 pattern/body pairs"] = {"checking that every pattern has a body to go with it", "adding _ before the final body"}, ["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 range to include start and stop"] = {"adding missing arguments"}, ["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"}, ["invalid 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"}, ["missing subject"] = {"adding an item to operate on"}, ["multisym method calls may only be in call position"] = {"using a period instead of a colon to reference a table's fields", "putting parens around this"}, ["tried to reference a macro without calling it"] = {"renaming the macro so as not to conflict with locals"}, ["tried to reference a special form without calling it"] = {"making sure to use prefix operators, not infix", "wrapping the special in a function if you need it to be first class"}, ["tried to use unquote outside quote"] = {"moving the form to inside a quoted form", "removing the comma"}, ["tried to use vararg with operator"] = {"accumulating over the operands"}, ["unable to bind (.*)"] = {"replacing the %s with an identifier"}, ["unexpected arguments"] = {"removing an argument", "checking for typos"}, ["unexpected closing delimiter (.)"] = {"deleting %s", "adding matching opening delimiter earlier"}, ["unexpected iterator clause"] = {"removing an argument", "checking for typos"}, ["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 identifier: (.*)"] = {"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 (.*)"] = {"renaming the local to _%s if it is meant to be unused", "fixing a typo so %s is used", "disabling the linter which checks for unused locals"}, ["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 s = nil for pat, sug in pairs(suggestions) do if s then break end local matches = {msg:match(pat)} - if (0 < #matches) then - local tbl_16_auto = {} - local i_17_auto = #tbl_16_auto + if next(matches) then + local tbl_17_ = {} + local i_18_ = #tbl_17_ for _, s0 in ipairs(sug) do - local val_18_auto = s0:format(unpack(matches)) - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + local val_19_ = s0:format(unpack(matches)) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - s = tbl_16_auto + s = tbl_17_ else - s = nil + s = nil end end return s @@ -3786,26 +4191,26 @@ package.preload["fennel.friend"] = package.preload["fennel.friend"] or function( end return matcher() else - local f = assert(io.open(filename)) - local function close_handlers_8_auto(ok_9_auto, ...) + local f = assert(_G.io.open(filename)) + local function close_handlers_10_(ok_11_, ...) f:close() - if ok_9_auto then + if ok_11_ then return ... else return error(..., 0) end end - local function _185_() + local function _190_() for _ = 2, line do f:read() end return f:read() end - return close_handlers_8_auto(_G.xpcall(_185_, (package.loaded.fennel or debug).traceback)) + return close_handlers_10_(_G.xpcall(_190_, (package.loaded.fennel or debug).traceback)) end end local function sub(str, start, _end) - if ((_end < start) or (#str < start) or (#str < _end)) then + if ((_end < start) or (#str < start)) then return "" elseif utf8_ok_3f then return string.sub(str, utf8.offset(str, start), ((utf8.offset(str, (_end + 1)) or (utf8.len(str) + 1)) - 1)) @@ -3817,36 +4222,42 @@ package.preload["fennel.friend"] = package.preload["fennel.friend"] or function( if ((opts and (false == opts["error-pinpoint"])) or (os and os.getenv and os.getenv("NO_COLOR"))) then return codeline else - local _let_188_ = (opts or {}) - local error_pinpoint = _let_188_["error-pinpoint"] + local _193_ = (opts or {}) + local error_pinpoint = _193_["error-pinpoint"] local endcol = (_3fendcol or col) - local eol + local eol = nil if utf8_ok_3f then eol = utf8.len(codeline) else eol = string.len(codeline) end - local _let_190_ = (error_pinpoint or {"\27[7m", "\27[0m"}) - local open = _let_190_[1] - local close = _let_190_[2] + local _195_ = (error_pinpoint or {"\27[7m", "\27[0m"}) + local open = _195_[1] + local close = _195_[2] return (sub(codeline, 1, col) .. open .. sub(codeline, (col + 1), (endcol + 1)) .. close .. sub(codeline, (endcol + 2), eol)) end end - local function friendly_msg(msg, _192_, source, opts) - local _arg_193_ = _192_ - local filename = _arg_193_["filename"] - local line = _arg_193_["line"] - local col = _arg_193_["col"] - local endcol = _arg_193_["endcol"] + local function friendly_msg(msg, _197_0, source, opts) + local _198_ = _197_0 + local col = _198_["col"] + local endcol = _198_["endcol"] + local endline = _198_["endline"] + local filename = _198_["filename"] + local line = _198_["line"] local ok, codeline = pcall(read_line, filename, line, source) + local endcol0 = nil + if (ok and codeline and (line ~= endline)) then + endcol0 = #codeline + else + endcol0 = endcol + end local out = {msg, ""} if (ok and codeline) then if col then - table.insert(out, highlight_line(codeline, col, endcol, opts)) + table.insert(out, highlight_line(codeline, col, endcol0, opts)) else table.insert(out, codeline) end - else end for _, suggestion in ipairs((suggest(msg) or {})) do table.insert(out, ("* Try %s."):format(suggestion)) @@ -3855,17 +4266,16 @@ package.preload["fennel.friend"] = package.preload["fennel.friend"] or function( end local function assert_compile(condition, msg, ast, source, opts) if not condition then - local _let_196_ = utils["ast-source"](ast) - local filename = _let_196_["filename"] - local line = _let_196_["line"] - local col = _let_196_["col"] - error(friendly_msg(("%s:%s:%s Compile error: %s"):format((filename or "unknown"), (line or "?"), (col or "?"), msg), utils["ast-source"](ast), source, opts), 0) - else + local _202_ = utils["ast-source"](ast) + local col = _202_["col"] + local filename = _202_["filename"] + local line = _202_["line"] + error(friendly_msg(("%s:%s:%s: Compile error: %s"):format((filename or "unknown"), (line or "?"), (col or "?"), msg), utils["ast-source"](ast), source, opts), 0) end return condition end local function parse_error(msg, filename, line, col, source, opts) - return error(friendly_msg(("%s:%s:%s Parse error: %s"):format(filename, line, col, msg), {filename = filename, line = line, col = col}, source, opts), 0) + return error(friendly_msg(("%s:%s:%s: Parse error: %s"):format(filename, line, col, msg), {col = col, filename = filename, line = line}, source, opts), 0) end return {["assert-compile"] = assert_compile, ["parse-error"] = parse_error} end @@ -3875,58 +4285,53 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( local unpack = (table.unpack or _G.unpack) local function granulate(getchunk) local c, index, done_3f = "", 1, false - local function _198_(parser_state) + local function _204_(parser_state) if not done_3f then if (index <= #c) then local b = c:byte(index) index = (index + 1) return b else - local _199_ = getchunk(parser_state) - local function _200_() - local char = _199_ + local _205_0 = getchunk(parser_state) + local function _206_() + local char = _205_0 return (char ~= "") end - if ((nil ~= _199_) and _200_()) then - local char = _199_ + if ((nil ~= _205_0) and _206_()) then + local char = _205_0 c = char index = 2 return c:byte() - elseif true then - local _ = _199_ - done_3f = true - return nil else + local _ = _205_0 + done_3f = true return nil end end - else - return nil end end - local function _204_() + local function _210_() c = "" return nil end - return _198_, _204_ + return _204_, _210_ end local function string_stream(str, _3foptions) local str0 = str:gsub("^#!", ";;") if _3foptions then _3foptions.source = str0 - else end local index = 1 - local function _206_() + local function _212_() local r = str0:byte(index) index = (index + 1) return r end - return _206_ + return _212_ end - local delims = {[40] = 41, [41] = true, [91] = 93, [93] = true, [123] = 125, [125] = true} + local delims = {[123] = 125, [125] = true, [40] = 41, [41] = true, [91] = 93, [93] = true} local function sym_char_3f(b) - local b0 + local b0 = nil if ("number" == type(b)) then b0 = b else @@ -3935,25 +4340,29 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( return ((32 < b0) and not delims[b0] and (b0 ~= 127) and (b0 ~= 34) and (b0 ~= 39) and (b0 ~= 126) and (b0 ~= 59) and (b0 ~= 44) and (b0 ~= 64) and (b0 ~= 96)) end local prefixes = {[35] = "hashfn", [39] = "quote", [44] = "unquote", [96] = "quote"} + local nan, negative_nan = nil, nil + if (45 == string.byte(tostring((0 / 0)))) then + nan, negative_nan = ( - (0 / 0)), (0 / 0) + else + nan, negative_nan = (0 / 0), ( - (0 / 0)) + end local function char_starter_3f(b) - return ((function(_208_,_209_,_210_) return (_208_ < _209_) and (_209_ < _210_) end)(1,b,127) or (function(_211_,_212_,_213_) return (_211_ < _212_) and (_212_ < _213_) end)(192,b,247)) - end - local function parser_fn(getbyte, filename, _214_) - local _arg_215_ = _214_ - local source = _arg_215_["source"] - local unfriendly = _arg_215_["unfriendly"] - local comments = _arg_215_["comments"] - local options = _arg_215_ + return (((1 < b) and (b < 127)) or ((192 < b) and (b < 247))) + end + local function parser_fn(getbyte, filename, _215_0) + local _216_ = _215_0 + local options = _216_ + local comments = _216_["comments"] + local source = _216_["source"] + local unfriendly = _216_["unfriendly"] local stack = {} local line, byteindex, col, prev_col, lastb = 1, 0, 0, 0, nil local function ungetb(ub) if char_starter_3f(ub) then col = (col - 1) - else end if (ub == 10) then line, col = (line - 1), prev_col - else end byteindex = (byteindex - 1) lastb = ub @@ -3966,149 +4375,167 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( else r = getbyte({["stack-size"] = #stack}) end - byteindex = (byteindex + 1) + if r then + byteindex = (byteindex + 1) + end if (r and char_starter_3f(r)) then col = (col + 1) - else end if (r == 10) then line, col, prev_col = (line + 1), 0, col - else end return r end local function whitespace_3f(b) - local function _225_() - local t_224_ = options.whitespace - if (nil ~= t_224_) then - t_224_ = (t_224_)[b] - else + local function _224_() + local _223_0 = options.whitespace + if (nil ~= _223_0) then + _223_0 = _223_0[b] end - return t_224_ + return _223_0 end - return ((b == 32) or (function(_221_,_222_,_223_) return (_221_ <= _222_) and (_222_ <= _223_) end)(9,b,13) or _225_()) + return ((b == 32) or ((9 <= b) and (b <= 13)) or _224_()) end local function parse_error(msg, _3fcol_adjust) local col0 = (col + (_3fcol_adjust or -1)) if (nil == utils["hook-opts"]("parse-error", options, msg, filename, (line or "?"), col0, source, utils.root.reset)) then utils.root.reset() - if (unfriendly or not _G.io or not _G.io.read) then - return error(string.format("%s:%s:%s Parse error: %s", filename, (line or "?"), col0, msg), 0) + if unfriendly then + return error(string.format("%s:%s:%s: Parse error: %s", filename, (line or "?"), col0, msg), 0) else return friend["parse-error"](msg, filename, (line or "?"), col0, source, options) end - else - return nil end end local function parse_stream() local whitespace_since_dispatch, done_3f, retval = true local function set_source_fields(source0) - source0.byteend, source0.endcol = byteindex, (col - 1) + source0.byteend, source0.endcol, source0.endline = byteindex, (col - 1), line return nil end - local function dispatch(v) - local _229_ = stack[#stack] - if (_229_ == nil) then - retval, done_3f, whitespace_since_dispatch = v, true, false + local function dispatch(v, _3fsource, _3fraw) + whitespace_since_dispatch = false + local v0 = nil + do + local _228_0 = utils["hook-opts"]("parse-form", options, v, _3fsource, _3fraw, stack) + if (nil ~= _228_0) then + local hookv = _228_0 + v0 = hookv + else + local _ = _228_0 + v0 = v + end + end + local _230_0 = stack[#stack] + if (_230_0 == nil) then + retval, done_3f = v0, true return nil - elseif ((_G.type(_229_) == "table") and (nil ~= (_229_).prefix)) then - local prefix = (_229_).prefix - local source0 + elseif ((_G.type(_230_0) == "table") and (nil ~= _230_0.prefix)) then + local prefix = _230_0.prefix + local source0 = nil do - local _230_ = table.remove(stack) - set_source_fields(_230_) - source0 = _230_ - end - local list = utils.list(utils.sym(prefix, source0), v) - for k, v0 in pairs(source0) do - list[k] = v0 + local _231_0 = table.remove(stack) + set_source_fields(_231_0) + source0 = _231_0 end - return dispatch(list) - elseif (nil ~= _229_) then - local top = _229_ - whitespace_since_dispatch = false - return table.insert(top, v) - else - return nil + local list = utils.list(utils.sym(prefix, source0), v0) + return dispatch(utils.copy(source0, list)) + elseif (nil ~= _230_0) then + local top = _230_0 + return table.insert(top, v0) end end local function badend() - local accum = utils.map(stack, "closer") - local _232_ + local closers = nil + do + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for _, _233_0 in ipairs(stack) do + local _234_ = _233_0 + local closer = _234_["closer"] + local val_19_ = closer + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end + end + closers = tbl_17_ + end + local _236_ if (#stack == 1) then - _232_ = "" + _236_ = "" else - _232_ = "s" + _236_ = "s" end - return parse_error(string.format("expected closing delimiter%s %s", _232_, string.char(unpack(accum)))) + return parse_error(string.format("expected closing delimiter%s %s", _236_, string.char(unpack(closers))), 0) end - local function skip_whitespace(b) + local function skip_whitespace(b, close_table) if (b and whitespace_3f(b)) then whitespace_since_dispatch = true - return skip_whitespace(getb()) - elseif (not b and (0 < #stack)) then - return badend() + return skip_whitespace(getb(), close_table) + elseif (not b and next(stack)) then + badend() + for i = #stack, 2, -1 do + close_table(stack[i].closer) + end + return stack[1].closer else return b end end local function parse_comment(b, contents) if (b and (10 ~= b)) then - local function _236_() - local _235_ = contents - table.insert(_235_, string.char(b)) - return _235_ + local function _239_() + table.insert(contents, string.char(b)) + return contents end - return parse_comment(getb(), _236_()) + return parse_comment(getb(), _239_()) elseif comments then ungetb(10) - return dispatch(utils.comment(table.concat(contents), {line = line, filename = filename})) - else - return nil + return dispatch(utils.comment(table.concat(contents), {filename = filename, line = line})) end end local function open_table(b) if not whitespace_since_dispatch then parse_error(("expected whitespace before opening delimiter " .. string.char(b))) - else end - return table.insert(stack, {bytestart = byteindex, closer = delims[b], filename = filename, line = line, col = (col - 1)}) + return table.insert(stack, {bytestart = byteindex, closer = delims[b], col = (col - 1), filename = filename, line = line}) end local function close_list(list) return dispatch(setmetatable(list, getmetatable(utils.list()))) end local function close_sequence(tbl) - local val = utils.sequence(unpack(tbl)) + local mt = getmetatable(utils.sequence()) for k, v in pairs(tbl) do - getmetatable(val)[k] = v + if ("number" ~= type(k)) then + mt[k] = v + tbl[k] = nil + end end - return dispatch(val) + return dispatch(setmetatable(tbl, mt)) end local function add_comment_at(comments0, index, node) - local _239_ = (comments0)[index] - if (nil ~= _239_) then - local existing = _239_ + local _243_0 = comments0[index] + if (nil ~= _243_0) then + local existing = _243_0 return table.insert(existing, node) - elseif true then - local _ = _239_ - comments0[index] = {node} - return nil else + local _ = _243_0 + comments0[index] = {node} return nil end end local function next_noncomment(tbl, i) if utils["comment?"](tbl[i]) then return next_noncomment(tbl, (i + 1)) - elseif (utils.sym(":") == tbl[i]) then + elseif utils["sym?"](tbl[i], ":") then return tostring(tbl[(i + 1)]) else return tbl[i] end end local function extract_comments(tbl) - local comments0 = {keys = {}, values = {}, last = {}} + local comments0 = {keys = {}, last = {}, values = {}} while utils["comment?"](tbl[#tbl]) do table.insert(comments0.last, 1, table.remove(tbl)) end @@ -4125,7 +4552,6 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( for i = #tbl, 1, -1 do if utils["comment?"](tbl[i]) then table.remove(tbl, i) - else end end return comments0 @@ -4137,13 +4563,11 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( if ((#tbl % 2) ~= 0) then byteindex = (byteindex - 1) parse_error("expected even number of values in table literal") - else end setmetatable(val, tbl) for i = 1, #tbl, 2 do if ((tostring(tbl[i]) == ":") and utils["sym?"](tbl[(i + 1)]) and utils["sym?"](tbl[i])) then tbl[i] = tostring(tbl[(i + 1)]) - else end val[tbl[i]] = tbl[(i + 1)] table.insert(keys, tbl[i]) @@ -4156,11 +4580,9 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( local top = table.remove(stack) if (top == nil) then parse_error(("unexpected closing delimiter " .. string.char(b))) - else end if (top.closer and (top.closer ~= b)) then parse_error(("mismatched closing delimiter " .. string.char(b) .. ", expected " .. string.char(top.closer))) - else end set_source_fields(top) if (b == 41) then @@ -4172,22 +4594,22 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( end end local function parse_string_loop(chars, b, state) - table.insert(chars, b) - local state0 + if b then + table.insert(chars, string.char(b)) + end + local state0 = nil do - local _249_ = {state, b} - if ((_G.type(_249_) == "table") and ((_249_)[1] == "base") and ((_249_)[2] == 92)) then + local _254_0 = {state, b} + if ((_G.type(_254_0) == "table") and (_254_0[1] == "base") and (_254_0[2] == 92)) then state0 = "backslash" - elseif ((_G.type(_249_) == "table") and ((_249_)[1] == "base") and ((_249_)[2] == 34)) then + elseif ((_G.type(_254_0) == "table") and (_254_0[1] == "base") and (_254_0[2] == 34)) then state0 = "done" - elseif ((_G.type(_249_) == "table") and ((_249_)[1] == "backslash") and ((_249_)[2] == 10)) then + elseif ((_G.type(_254_0) == "table") and (_254_0[1] == "backslash") and (_254_0[2] == 10)) then table.remove(chars, (#chars - 1)) state0 = "base" - elseif true then - local _ = _249_ - state0 = "base" else - state0 = nil + local _ = _254_0 + state0 = "base" end end if (b and (state0 ~= "done")) then @@ -4197,70 +4619,69 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( end end local function escape_char(c) - return ({[7] = "\\a", [8] = "\\b", [9] = "\\t", [10] = "\\n", [11] = "\\v", [12] = "\\f", [13] = "\\r"})[c:byte()] + return ({[10] = "\\n", [11] = "\\v", [12] = "\\f", [13] = "\\r", [7] = "\\a", [8] = "\\b", [9] = "\\t"})[c:byte()] end - local function parse_string() + local function parse_string(source0) + if not whitespace_since_dispatch then + utils.warn("expected whitespace before string", nil, filename, line) + end table.insert(stack, {closer = 34}) - local chars = {34} + local chars = {"\""} if not parse_string_loop(chars, getb(), "base") then badend() - else end table.remove(stack) - local raw = string.char(unpack(chars)) + local raw = table.concat(chars) local formatted = raw:gsub("[\7-\13]", escape_char) - local _253_ = (rawget(_G, "loadstring") or load)(("return " .. formatted)) - if (nil ~= _253_) then - local load_fn = _253_ - return dispatch(load_fn()) - elseif (_253_ == nil) then + local _259_0 = (rawget(_G, "loadstring") or load)(("return " .. formatted)) + if (nil ~= _259_0) then + local load_fn = _259_0 + return dispatch(load_fn(), source0, raw) + elseif (_259_0 == nil) then return parse_error(("Invalid string: " .. raw)) - else - return nil end end local function parse_prefix(b) - table.insert(stack, {prefix = prefixes[b], filename = filename, line = line, bytestart = byteindex, col = (col - 1)}) + table.insert(stack, {bytestart = byteindex, col = (col - 1), filename = filename, line = line, prefix = prefixes[b]}) local nextb = getb() - if (whitespace_3f(nextb) or (true == delims[nextb])) then - if (b ~= 35) then - parse_error("invalid whitespace after quoting prefix") - else - end - table.remove(stack) - dispatch(utils.sym("#")) - else + local trailing_whitespace_3f = (whitespace_3f(nextb) or (true == delims[nextb])) + if (trailing_whitespace_3f and (b ~= 35)) then + parse_error("invalid whitespace after quoting prefix") + end + ungetb(nextb) + if (trailing_whitespace_3f and (b == 35)) then + local source0 = table.remove(stack) + set_source_fields(source0) + return dispatch(utils.sym("#", source0)) end - return ungetb(nextb) end local function parse_sym_loop(chars, b) if (b and sym_char_3f(b)) then - table.insert(chars, b) + table.insert(chars, string.char(b)) return parse_sym_loop(chars, getb()) else if b then ungetb(b) - else end return chars end end - local function parse_number(rawstr) - local number_with_stripped_underscores = (not rawstr:find("^_") and rawstr:gsub("_", "")) - if rawstr:match("^%d") then - dispatch((tonumber(number_with_stripped_underscores) or parse_error(("could not read number \"" .. rawstr .. "\"")))) + local function parse_number(rawstr, source0) + local trimmed = (not rawstr:find("^_") and rawstr:gsub("_", "")) + if ((trimmed == "nan") or (trimmed == "-nan")) then + return false + elseif rawstr:match("^%d") then + dispatch((tonumber(trimmed) or parse_error(("could not read number \"" .. rawstr .. "\""))), source0, rawstr) return true else - local _259_ = tonumber(number_with_stripped_underscores) - if (nil ~= _259_) then - local x = _259_ - dispatch(x) + local _265_0 = tonumber(trimmed) + if (nil ~= _265_0) then + local x = _265_0 + dispatch(x, source0, rawstr) return true - elseif true then - local _ = _259_ - return false else - return nil + local _ = _265_0 + return false end end end @@ -4269,35 +4690,41 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( return (rawstr:find(pat) - utils.len(rawstr) - 1) end if (rawstr:match("^~") and (rawstr ~= "~=")) then - return parse_error("invalid character: ~") - elseif rawstr:match("%.[0-9]") then - return parse_error(("can't start multisym segment with a digit: " .. rawstr), col_adjust("%.[0-9]")) + parse_error("invalid character: ~") elseif (rawstr:match("[%.:][%.:]") and (rawstr ~= "..") and (rawstr ~= "$...")) then - return parse_error(("malformed multisym: " .. rawstr), col_adjust("[%.:][%.:]")) + parse_error(("malformed multisym: " .. rawstr), col_adjust("[%.:][%.:]")) elseif ((rawstr ~= ":") and rawstr:match(":$")) then - return parse_error(("malformed multisym: " .. rawstr), col_adjust(":$")) + parse_error(("malformed multisym: " .. rawstr), col_adjust(":$")) elseif rawstr:match(":.+[%.:]") then - return parse_error(("method must be last component of multisym: " .. rawstr), col_adjust(":.+[%.:]")) - else - return rawstr + parse_error(("method must be last component of multisym: " .. rawstr), col_adjust(":.+[%.:]")) + end + if not whitespace_since_dispatch then + utils.warn("expected whitespace before token", nil, filename, line) end + return rawstr end local function parse_sym(b) - local source0 = {bytestart = byteindex, filename = filename, line = line, col = (col - 1)} - local rawstr = string.char(unpack(parse_sym_loop({b}, getb()))) + local source0 = {bytestart = byteindex, col = (col - 1), filename = filename, line = line} + local rawstr = table.concat(parse_sym_loop({string.char(b)}, getb())) set_source_fields(source0) if (rawstr == "true") then - return dispatch(true) + return dispatch(true, source0) elseif (rawstr == "false") then - return dispatch(false) + return dispatch(false, source0) elseif (rawstr == "...") then return dispatch(utils.varg(source0)) + elseif (rawstr == ".inf") then + return dispatch((1 / 0), source0, rawstr) + elseif (rawstr == "-.inf") then + return dispatch((-1 / 0), source0, rawstr) + elseif (rawstr == ".nan") then + return dispatch(nan, source0, rawstr) + elseif (rawstr == "-.nan") then + return dispatch(negative_nan, source0, rawstr) elseif rawstr:match("^:.+$") then - return dispatch(rawstr:sub(2)) - elseif not parse_number(rawstr) then + return dispatch(rawstr:sub(2), source0, rawstr) + elseif not parse_number(rawstr, source0) then return dispatch(utils.sym(check_malformed_sym(rawstr), source0)) - else - return nil end end local function parse_loop(b) @@ -4309,30 +4736,29 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( elseif delims[b] then close_table(b) elseif (b == 34) then - parse_string(b) + parse_string({bytestart = byteindex, col = col, filename = filename, line = line}) elseif prefixes[b] then parse_prefix(b) elseif (sym_char_3f(b) or (b == string.byte("~"))) then parse_sym(b) elseif not utils["hook-opts"]("illegal-char", options, b, getb, ungetb, dispatch) then parse_error(("invalid character: " .. string.char(b))) - else end if not b then return nil elseif done_3f then return true, retval else - return parse_loop(skip_whitespace(getb())) + return parse_loop(skip_whitespace(getb(), close_table)) end end - return parse_loop(skip_whitespace(getb())) + return parse_loop(skip_whitespace(getb(), close_table)) end - local function _266_() - stack, line, byteindex, col, lastb = {}, 1, 0, 0, nil + local function _273_() + stack, line, byteindex, col, lastb = {}, 1, 0, 0, ((lastb ~= 10) and lastb) return nil end - return parse_stream, _266_ + return parse_stream, _273_ end local function parser(stream_or_string, _3ffilename, _3foptions) local filename = (_3ffilename or "unknown") @@ -4344,109 +4770,95 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( return parser_fn(stream_or_string, filename, options) end end - return {granulate = granulate, parser = parser, ["string-stream"] = string_stream, ["sym-char?"] = sym_char_3f} + return {["string-stream"] = string_stream, ["sym-char?"] = sym_char_3f, granulate = granulate, parser = parser} end package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) - local type_order = {number = 1, boolean = 2, string = 3, table = 4, ["function"] = 5, userdata = 6, thread = 7} - local default_opts = {["one-line?"] = false, ["detect-cycles?"] = true, ["empty-as-sequence?"] = false, ["metamethod?"] = true, ["prefer-colon?"] = false, ["escape-newlines?"] = false, ["utf8?"] = true, ["line-length"] = 80, depth = 128, ["max-sparse-gap"] = 10} + local type_order = {["function"] = 5, boolean = 2, number = 1, string = 3, table = 4, thread = 7, userdata = 6} + local default_opts = {["detect-cycles?"] = true, ["empty-as-sequence?"] = false, ["escape-newlines?"] = false, ["line-length"] = 80, ["max-sparse-gap"] = 10, ["metamethod?"] = true, ["one-line?"] = false, ["prefer-colon?"] = false, ["utf8?"] = true, depth = 128} local lua_pairs = pairs local lua_ipairs = ipairs local function pairs(t) - local _1_ = getmetatable(t) - if ((_G.type(_1_) == "table") and (nil ~= (_1_).__pairs)) then - local p = (_1_).__pairs + local _1_0 = getmetatable(t) + if ((_G.type(_1_0) == "table") and (nil ~= _1_0.__pairs)) then + local p = _1_0.__pairs return p(t) - elseif true then - local _ = _1_ - return lua_pairs(t) else - return nil + local _ = _1_0 + return lua_pairs(t) end end local function ipairs(t) - local _3_ = getmetatable(t) - if ((_G.type(_3_) == "table") and (nil ~= (_3_).__ipairs)) then - local i = (_3_).__ipairs + local _3_0 = getmetatable(t) + if ((_G.type(_3_0) == "table") and (nil ~= _3_0.__ipairs)) then + local i = _3_0.__ipairs return i(t) - elseif true then - local _ = _3_ - return lua_ipairs(t) else - return nil + local _ = _3_0 + return lua_ipairs(t) end end local function length_2a(t) - local _5_ = getmetatable(t) - if ((_G.type(_5_) == "table") and (nil ~= (_5_).__len)) then - local l = (_5_).__len + local _5_0 = getmetatable(t) + if ((_G.type(_5_0) == "table") and (nil ~= _5_0.__len)) then + local l = _5_0.__len return l(t) - elseif true then - local _ = _5_ - return #t else - return nil + local _ = _5_0 + return #t end end local function get_default(key) - local _7_ = default_opts[key] - if (_7_ == nil) then + local _7_0 = default_opts[key] + if (_7_0 == nil) then return error(("option '%s' doesn't have a default value, use the :after key to set it"):format(tostring(key))) - elseif (nil ~= _7_) then - local v = _7_ + elseif (nil ~= _7_0) then + local v = _7_0 return v - else - return nil end end local function getopt(options, key) - local val = options[key] - local _9_ = val - if ((_G.type(_9_) == "table") and (nil ~= (_9_).once)) then - local val_2a = (_9_).once + local _9_0 = options[key] + if ((_G.type(_9_0) == "table") and (nil ~= _9_0.once)) then + local val_2a = _9_0.once return val_2a - elseif true then - local _ = _9_ - return val else - return nil + local _3fval = _9_0 + return _3fval end end local function normalize_opts(options) - local tbl_13_auto = {} + local tbl_14_ = {} for k, v in pairs(options) do - local k_14_auto, v_15_auto = nil, nil + local k_15_, v_16_ = nil, nil local function _12_() - local _11_ = v - if ((_G.type(_11_) == "table") and (nil ~= (_11_).after)) then - local val = (_11_).after + local _11_0 = v + if ((_G.type(_11_0) == "table") and (nil ~= _11_0.after)) then + local val = _11_0.after return val else local function _13_() return v.once end - if ((_G.type(_11_) == "table") and _13_()) then + if ((_G.type(_11_0) == "table") and _13_()) then return get_default(k) - elseif true then - local _ = _11_ - return v else - return nil + local _ = _11_0 + return v end end end - k_14_auto, v_15_auto = k, _12_() - if ((k_14_auto ~= nil) and (v_15_auto ~= nil)) then - tbl_13_auto[k_14_auto] = v_15_auto - else + k_15_, v_16_ = k, _12_() + if ((k_15_ ~= nil) and (v_16_ ~= nil)) then + tbl_14_[k_15_] = v_16_ end end - return tbl_13_auto + return tbl_14_ end - local function sort_keys(_16_, _18_) - local _arg_17_ = _16_ - local a = _arg_17_[1] - local _arg_19_ = _18_ - local b = _arg_19_[1] + local function sort_keys(_16_0, _18_0) + local _17_ = _16_0 + local a = _17_[1] + local _19_ = _18_0 + local b = _19_[1] local ta = type(a) local tb = type(b) if ((ta == tb) and ((ta == "string") or (ta == "number"))) then @@ -4469,25 +4881,23 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) local gap = 0 if (0 < length_2a(kv)) then local i = 0 - for _, _22_ in ipairs(kv) do - local _each_23_ = _22_ - local k = _each_23_[1] + for _, _22_0 in ipairs(kv) do + local _23_ = _22_0 + local k = _23_[1] if (gap < (k - i)) then gap = (k - i) - else end i = k end - else end return gap end local function fill_gaps(kv) local missing_indexes = {} local i = 0 - for _, _26_ in ipairs(kv) do - local _each_27_ = _26_ - local j = _each_27_[1] + for _, _26_0 in ipairs(kv) do + local _27_ = _26_0 + local j = _27_[1] i = (i + 1) while (i < j) do table.insert(missing_indexes, i) @@ -4506,7 +4916,6 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) for k, v in pairs(t) do if ((type(k) ~= "number") or (k < 1)) then assoc_3f = true - else end insert(kv, {k, v}) end @@ -4517,7 +4926,6 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) else fill_gaps(kv) end - else end if (length_2a(kv) == 0) then return kv, "empty" @@ -4543,40 +4951,34 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) else appearances[t] = ((appearances[t] or 0) + 1) end - else end return appearances end local function save_table(t, seen) local seen0 = (seen or {len = 0}) local id = (seen0.len + 1) - if not (seen0)[t] then + if not seen0[t] then seen0[t] = id seen0.len = id - else end return seen0 end - local function detect_cycle(t, seen, _3fk) + local function detect_cycle(t, seen) if ("table" == type(t)) then seen[t] = true - local _36_, _37_ = next(t, _3fk) - if ((nil ~= _36_) and (nil ~= _37_)) then - local k = _36_ - local v = _37_ - return (seen[k] or detect_cycle(k, seen) or seen[v] or detect_cycle(v, seen) or detect_cycle(t, seen, k)) - else - return nil + local res = nil + for k, v in pairs(t) do + if res then break end + res = (seen[k] or detect_cycle(k, seen) or seen[v] or detect_cycle(v, seen)) end - else - return nil + return res end end local function visible_cycle_3f(t, options) return (getopt(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(indent, id) - local opener_length + local opener_length = nil if id then opener_length = (length_2a(tostring(id)) + 2) else @@ -4587,16 +4989,16 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) local pp = nil local function concat_table_lines(elements, options, multiline_3f, indent, table_type, prefix, last_comment_3f) local indent_str = ("\n" .. string.rep(" ", indent)) - local open - local function _41_() + local open = nil + local function _38_() if ("seq" == table_type) then return "[" else return "{" end end - open = ((prefix or "") .. _41_()) - local close + open = ((prefix or "") .. _38_()) + local close = nil if ("seq" == table_type) then close = "]" else @@ -4604,14 +5006,14 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) end local oneline = (open .. table.concat(elements, " ") .. close) if (not getopt(options, "one-line?") and (multiline_3f or (options["line-length"] < (indent + length_2a(oneline))) or last_comment_3f)) then - local function _43_() + local function _40_() if last_comment_3f then return indent_str else return "" end end - return (open .. table.concat(elements, indent_str) .. _43_() .. close) + return (open .. table.concat(elements, indent_str) .. _40_() .. close) else return oneline end @@ -4642,44 +5044,43 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) local visible_cycle_3f0 = visible_cycle_3f(t, options) local id0 = (visible_cycle_3f0 and options.seen[t]) local indent0 = table_indent(indent, id0) - local slength + local slength = nil if getopt(options, "utf8?") then slength = utf8_len else - local function _46_(_241) + local function _43_(_241) return #_241 end - slength = _46_ + slength = _43_ end - local prefix + local prefix = nil if visible_cycle_3f0 then prefix = ("@" .. id0) else prefix = "" end - local items + local items = nil do local options0 = normalize_opts(options) - local tbl_16_auto = {} - local i_17_auto = #tbl_16_auto - for _, _49_ in ipairs(kv) do - local _each_50_ = _49_ - local k = _each_50_[1] - local v = _each_50_[2] - local val_18_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for _, _46_0 in ipairs(kv) do + local _47_ = _46_0 + local k = _47_[1] + local v = _47_[2] + local val_19_ = nil do local k0 = pp(k, options0, (indent0 + 1), true) local v0 = pp(v, options0, (indent0 + slength(k0) + 1)) multiline_3f = (multiline_3f or k0:find("\n") or v0:find("\n")) - val_18_auto = (k0 .. " " .. v0) + val_19_ = (k0 .. " " .. v0) end - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - items = tbl_16_auto + items = tbl_17_ end return concat_table_lines(items, options, multiline_3f, indent0, "table", prefix, false) end @@ -4695,35 +5096,34 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) local visible_cycle_3f0 = visible_cycle_3f(t, options) local id0 = (visible_cycle_3f0 and options.seen[t]) local indent0 = table_indent(indent, id0) - local prefix + local prefix = nil if visible_cycle_3f0 then prefix = ("@" .. id0) else prefix = "" end local last_comment_3f = comment_3f(t[#t]) - local items + local items = nil do local options0 = normalize_opts(options) - local tbl_16_auto = {} - local i_17_auto = #tbl_16_auto - for _, _54_ in ipairs(kv) do - local _each_55_ = _54_ - local _0 = _each_55_[1] - local v = _each_55_[2] - local val_18_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for _, _51_0 in ipairs(kv) do + local _52_ = _51_0 + local _0 = _52_[1] + local v = _52_[2] + local val_19_ = nil do local v0 = pp(v, options0, indent0) multiline_3f = (multiline_3f or v0:find("\n") or v0:find("^;")) - val_18_auto = v0 + val_19_ = v0 end - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - items = tbl_16_auto + items = tbl_17_ end return concat_table_lines(items, options, multiline_3f, indent0, "seq", prefix, last_comment_3f) end @@ -4736,22 +5136,21 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) return "{}" end else - local oneline - local _59_ + local oneline = nil + local _56_ do - local tbl_16_auto = {} - local i_17_auto = #tbl_16_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ for _, line in ipairs(lines) do - local val_18_auto = line:gsub("^%s+", "") - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + local val_19_ = line:gsub("^%s+", "") + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - _59_ = tbl_16_auto + _56_ = tbl_17_ end - oneline = table.concat(_59_, " ") + oneline = table.concat(_56_, " ") if (not getopt(options, "one-line?") and (force_multi_line_3f or oneline:find("\n") or (options["line-length"] < (indent + length_2a(oneline))))) then return table.concat(lines, ("\n" .. string.rep(" ", indent))) else @@ -4767,11 +5166,11 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) return "{...}" end else - local _ - local function _64_(_241) + local _ = nil + local function _61_(_241) return visible_cycle_3f(_241, options) end - options["visible-cycle?"] = _64_ + options["visible-cycle?"] = _61_ _ = nil local lines, force_multi_line_3f = nil, nil do @@ -4779,92 +5178,132 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) lines, force_multi_line_3f = metamethod(t, pp, options0, indent) end options["visible-cycle?"] = nil - local _65_ = type(lines) - if (_65_ == "string") then + local _62_0 = type(lines) + if (_62_0 == "string") then return lines - elseif (_65_ == "table") then + elseif (_62_0 == "table") then return concat_lines(lines, options, indent, force_multi_line_3f) - elseif true then - local _0 = _65_ - return error("__fennelview metamethod must return a table of lines") else - return nil + local _0 = _62_0 + return error("__fennelview metamethod must return a table of lines") end end end local function pp_table(x, options, indent) options.level = (options.level + 1) - local x0 + local x0 = nil do - local _68_ + local _65_0 = nil if getopt(options, "metamethod?") then - local _69_ = x - if (nil ~= _69_) then - local _70_ = getmetatable(_69_) - if (nil ~= _70_) then - _68_ = (_70_).__fennelview + local _66_0 = x + if (nil ~= _66_0) then + local _67_0 = getmetatable(_66_0) + if (nil ~= _67_0) then + _65_0 = _67_0.__fennelview else - _68_ = _70_ + _65_0 = _67_0 end else - _68_ = _69_ + _65_0 = _66_0 end else - _68_ = nil + _65_0 = nil end - if (nil ~= _68_) then - local metamethod = _68_ + if (nil ~= _65_0) then + local metamethod = _65_0 x0 = pp_metamethod(x, metamethod, options, indent) - elseif true then - local _ = _68_ - local _74_, _75_ = table_kv_pairs(x, options) - if (true and (_75_ == "empty")) then - local _0 = _74_ + else + local _ = _65_0 + local _71_0, _72_0 = table_kv_pairs(x, options) + if (true and (_72_0 == "empty")) then + local _0 = _71_0 if getopt(options, "empty-as-sequence?") then x0 = "[]" else x0 = "{}" end - elseif ((nil ~= _74_) and (_75_ == "table")) then - local kv = _74_ + elseif ((nil ~= _71_0) and (_72_0 == "table")) then + local kv = _71_0 x0 = pp_associative(x, kv, options, indent) - elseif ((nil ~= _74_) and (_75_ == "seq")) then - local kv = _74_ + elseif ((nil ~= _71_0) and (_72_0 == "seq")) then + local kv = _71_0 x0 = pp_sequence(x, kv, options, indent) else - x0 = nil - end - else x0 = nil + end end end options.level = (options.level - 1) return x0 end - local function number__3estring(n) - local _79_ = string.gsub(tostring(n), ",", ".") - return _79_ + local function exponential_notation(n, fallback) + local s = nil + for i = 0, 308 do + if s then break end + local s0 = string.format(("%." .. i .. "e"), n) + if (n == tonumber(s0)) then + local exp = s0:match("e%+?(%d+)$") + if (exp and (14 < tonumber(exp))) then + s = s0 + else + s = fallback + end + else + s = nil + end + end + return s + end + local inf_str = tostring((1 / 0)) + local neg_inf_str = tostring((-1 / 0)) + local function number__3estring(n, options) + local val = nil + if (n ~= n) then + if (45 == string.byte(tostring(n))) then + val = (options["negative-nan"] or "-.nan") + else + val = (options.nan or ".nan") + end + elseif (math.floor(n) == n) then + local s1 = string.format("%.f", n) + if (s1 == inf_str) then + val = (options.infinity or ".inf") + elseif (s1 == neg_inf_str) then + val = (options["negative-infinity"] or "-.inf") + elseif (s1 == tostring(n)) then + val = s1 + else + val = (exponential_notation(n, s1) or s1) + end + else + val = tostring(n) + end + local _81_0 = string.gsub(val, ",", ".") + return _81_0 end local function colon_string_3f(s) - return s:find("^[-%w?^_!$%&*+./@|<=>]+$") + return s:find("^[-%w?^_!$%&*+./|<=>]+$") + end + local utf8_inits = {{["max-byte"] = 127, ["max-code"] = 127, ["min-byte"] = 0, ["min-code"] = 0, len = 1}, {["max-byte"] = 223, ["max-code"] = 2047, ["min-byte"] = 192, ["min-code"] = 128, len = 2}, {["max-byte"] = 239, ["max-code"] = 65535, ["min-byte"] = 224, ["min-code"] = 2048, len = 3}, {["max-byte"] = 247, ["max-code"] = 1114111, ["min-byte"] = 240, ["min-code"] = 65536, len = 4}} + local function default_byte_escape(byte, _options) + return ("\\%03d"):format(byte) end - local utf8_inits = {{["min-byte"] = 0, ["max-byte"] = 127, ["min-code"] = 0, ["max-code"] = 127, len = 1}, {["min-byte"] = 192, ["max-byte"] = 223, ["min-code"] = 128, ["max-code"] = 2047, len = 2}, {["min-byte"] = 224, ["max-byte"] = 239, ["min-code"] = 2048, ["max-code"] = 65535, len = 3}, {["min-byte"] = 240, ["max-byte"] = 247, ["min-code"] = 65536, ["max-code"] = 1114111, len = 4}} - local function utf8_escape(str) + local function utf8_escape(str, options) local function validate_utf8(str0, index) local inits = utf8_inits local byte = string.byte(str0, index) - local init + local init = nil do local ret = nil for _, init0 in ipairs(inits) do if ret then break end - ret = (byte and (function(_80_,_81_,_82_) return (_80_ <= _81_) and (_81_ <= _82_) end)(init0["min-byte"],byte,init0["max-byte"]) and init0) + ret = (byte and (function(_82_,_83_,_84_) return (_82_ <= _83_) and (_83_ <= _84_) end)(init0["min-byte"],byte,init0["max-byte"]) and init0) end init = ret end - local code - local function _83_() - local code0 + local code = nil + local function _85_() + local code0 = nil if init then code0 = (byte - init["min-byte"]) else @@ -4872,26 +5311,24 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) end for i = (index + 1), (index + init.len + -1) do local byte0 = string.byte(str0, i) - code0 = (byte0 and code0 and (function(_85_,_86_,_87_) return (_85_ <= _86_) and (_86_ <= _87_) end)(128,byte0,191) and ((code0 * 64) + (byte0 - 128))) + code0 = (byte0 and code0 and ((128 <= byte0) and (byte0 <= 191)) and ((code0 * 64) + (byte0 - 128))) end return code0 end - code = (init and _83_()) - if (code and (function(_88_,_89_,_90_) return (_88_ <= _89_) and (_89_ <= _90_) end)(init["min-code"],code,init["max-code"]) and not (function(_91_,_92_,_93_) return (_91_ <= _92_) and (_92_ <= _93_) end)(55296,code,57343)) then + code = (init and _85_()) + if (code and (function(_87_,_88_,_89_) return (_87_ <= _88_) and (_88_ <= _89_) end)(init["min-code"],code,init["max-code"]) and not ((55296 <= code) and (code <= 57343))) then return init.len - else - return nil end end local index = 1 local output = {} + local byte_escape = (getopt(options, "byte-escape") or default_byte_escape) while (index <= #str) do local nexti = (string.find(str, "[\128-\255]", index) or (#str + 1)) local len = validate_utf8(str, nexti) table.insert(output, string.sub(str, index, (nexti + (len or 0) + -1))) if (not len and (nexti <= #str)) then - table.insert(output, string.format("\\%03d", string.byte(str, nexti))) - else + table.insert(output, byte_escape(str:byte(nexti), options)) end if len then index = (nexti + len) @@ -4904,38 +5341,38 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) local function pp_string(str, options, indent) local len = length_2a(str) local esc_newline_3f = ((len < 2) or (getopt(options, "escape-newlines?") and (len < (options["line-length"] - indent)))) - local escs - local _97_ + local byte_escape = (getopt(options, "byte-escape") or default_byte_escape) + local escs = nil + local _93_ if esc_newline_3f then - _97_ = "\\n" + _93_ = "\\n" else - _97_ = "\n" + _93_ = "\n" end - local function _99_(_241, _242) - return ("\\%03d"):format(_242:byte()) + local function _95_(_241, _242) + return byte_escape(_242:byte(), options) end - escs = setmetatable({["\7"] = "\\a", ["\8"] = "\\b", ["\12"] = "\\f", ["\11"] = "\\v", ["\13"] = "\\r", ["\9"] = "\\t", ["\\"] = "\\\\", ["\""] = "\\\"", ["\n"] = _97_}, {__index = _99_}) + escs = setmetatable({["\""] = "\\\"", ["\11"] = "\\v", ["\12"] = "\\f", ["\13"] = "\\r", ["\7"] = "\\a", ["\8"] = "\\b", ["\9"] = "\\t", ["\\"] = "\\\\", ["\n"] = _93_}, {__index = _95_}) local str0 = ("\"" .. str:gsub("[%c\\\"]", escs) .. "\"") if getopt(options, "utf8?") then - return utf8_escape(str0) + return utf8_escape(str0, options) else return str0 end end local function make_options(t, options) - local defaults + local defaults = nil do - local tbl_13_auto = {} + local tbl_14_ = {} for k, v in pairs(default_opts) do - local k_14_auto, v_15_auto = k, v - if ((k_14_auto ~= nil) and (v_15_auto ~= nil)) then - tbl_13_auto[k_14_auto] = v_15_auto - else + local k_15_, v_16_ = k, v + if ((k_15_ ~= nil) and (v_16_ ~= nil)) then + tbl_14_[k_15_] = v_16_ end end - defaults = tbl_13_auto + defaults = tbl_14_ end - local overrides = {level = 0, appearances = count_table_appearances(t, {}), seen = {len = 0}} + local overrides = {appearances = count_table_appearances(t, {}), level = 0, seen = {len = 0}} for k, v in pairs((options or {})) do defaults[k] = v end @@ -4944,30 +5381,29 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) end return defaults end - local function _102_(x, options, indent, colon_3f) + local function _98_(x, options, indent, colon_3f) local indent0 = (indent or 0) local options0 = (options or make_options(x)) - local x0 + local x0 = nil if options0.preprocess then x0 = options0.preprocess(x, options0) else x0 = x end local tv = type(x0) - local function _105_() - local _104_ = getmetatable(x0) - if (nil ~= _104_) then - return (_104_).__fennelview - else - return _104_ + local function _101_() + local _100_0 = getmetatable(x0) + if ((_G.type(_100_0) == "table") and true) then + local __fennelview = _100_0.__fennelview + return __fennelview end end - if ((tv == "table") or ((tv == "userdata") and _105_())) then + if ((tv == "table") or ((tv == "userdata") and _101_())) then return pp_table(x0, options0, indent0) elseif (tv == "number") then - return number__3estring(x0) + return number__3estring(x0, options0) else - local function _107_() + local function _103_() if (colon_3f ~= nil) then return colon_3f elseif ("function" == type(options0["prefer-colon?"])) then @@ -4976,7 +5412,7 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) return getopt(options0, "prefer-colon?") end end - if ((tv == "string") and colon_string_3f(x0) and _107_()) then + if ((tv == "string") and colon_string_3f(x0) and _103_()) then return (":" .. x0) elseif (tv == "string") then return pp_string(x0, options0, indent0) @@ -4987,20 +5423,20 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) end end end - pp = _102_ - local function view(x, _3foptions) + pp = _98_ + local function _view(x, _3foptions) return pp(x, make_options(x, _3foptions), 0) end - return view + return _view end package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(...) local view = require("fennel.view") - local version = "1.3.0" + local version = "1.5.1" local function luajit_vm_3f() return ((nil ~= _G.jit) and (type(_G.jit) == "table") and (nil ~= _G.jit.on) and (nil ~= _G.jit.off) and (type(_G.jit.version_num) == "number")) end local function luajit_vm_version() - local jit_os + local jit_os = nil if (_G.jit.os == "OSX") then jit_os = "macOS" else @@ -5023,200 +5459,160 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. return ("PUC " .. _VERSION) end end - local function runtime_version() - return ("Fennel " .. version .. " on " .. lua_vm_version()) - end - local function warn(message) - if (_G.io and _G.io.stderr) then - return (_G.io.stderr):write(("--WARNING: %s\n"):format(tostring(message))) + local function runtime_version(_3fas_table) + if _3fas_table then + return {fennel = version, lua = lua_vm_version()} else - return nil + return ("Fennel " .. version .. " on " .. lua_vm_version()) end end - local len + local len = nil do - local _112_, _113_ = pcall(require, "utf8") - if ((_112_ == true) and (nil ~= _113_)) then - local utf8 = _113_ + local _108_0, _109_0 = pcall(require, "utf8") + if ((_108_0 == true) and (nil ~= _109_0)) then + local utf8 = _109_0 len = utf8.len - elseif true then - local _ = _112_ - len = string.len else - len = nil + local _ = _108_0 + len = string.len end end - local function mt_keys_in_order(t, out, used_keys) - for _, k in ipairs(getmetatable(t).keys) do - if (t[k] and not used_keys[k]) then - used_keys[k] = true - table.insert(out, k) - else + local kv_order = {boolean = 2, number = 1, string = 3, table = 4} + local function kv_compare(a, b) + local _111_0, _112_0 = type(a), type(b) + if (((_111_0 == "number") and (_112_0 == "number")) or ((_111_0 == "string") and (_112_0 == "string"))) then + return (a < b) + else + local function _113_() + local a_t = _111_0 + local b_t = _112_0 + return (a_t ~= b_t) end - end - for k in pairs(t) do - if not used_keys[k] then - table.insert(out, k) + if (((nil ~= _111_0) and (nil ~= _112_0)) and _113_()) then + local a_t = _111_0 + local b_t = _112_0 + return ((kv_order[a_t] or 5) < (kv_order[b_t] or 5)) else + local _ = _111_0 + return (tostring(a) < tostring(b)) end end - return out end - local function stablepairs(t) - local keys - local _118_ + local function add_stable_keys(succ, prev_key, src, _3fpred) + local first = prev_key + local last = nil do - local t_117_ = getmetatable(t) - if (nil ~= t_117_) then - t_117_ = (t_117_).keys - else - end - _118_ = t_117_ - end - if _118_ then - keys = mt_keys_in_order(t, {}, {}) - else - local _120_ - do - local tbl_16_auto = {} - local i_17_auto = #tbl_16_auto - for k in pairs(t) do - local val_18_auto = k - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto + local prev = prev_key + for _, k in ipairs(src) do + if ((prev == k) or (succ[k] ~= nil) or (_3fpred and not _3fpred(k))) then + prev = prev + else + if (first == nil) then + first = k + prev = k + elseif (prev ~= nil) then + succ[prev] = k + prev = k else + prev = k end end - _120_ = tbl_16_auto end - local function _122_(_241, _242) - return (tostring(_241) < tostring(_242)) - end - table.sort(_120_, _122_) - keys = _120_ + last = prev end - local succ + return succ, last, first + end + local function stablepairs(t) + local mt_keys = nil do - local tbl_13_auto = {} - for i, k in ipairs(keys) do - local k_14_auto, v_15_auto = k, keys[(i + 1)] - if ((k_14_auto ~= nil) and (v_15_auto ~= nil)) then - tbl_13_auto[k_14_auto] = v_15_auto - else - end + local _117_0 = getmetatable(t) + if (nil ~= _117_0) then + _117_0 = _117_0.keys end - succ = tbl_13_auto + mt_keys = _117_0 end - local function stablenext(tbl, key) - local next_key - if (key == nil) then - next_key = keys[1] - else - next_key = succ[key] - end - return next_key, tbl[next_key] + local succ, prev, first_mt = nil, nil, nil + local function _119_(_241) + return t[_241] end - return stablenext, t, nil - end - local function get_in(tbl, path, _3ffallback) - assert(("table" == type(tbl)), "get-in expects path to be a table") - if (0 == #path) then - return _3ffallback - else - local _126_ + succ, prev, first_mt = add_stable_keys({}, nil, (mt_keys or {}), _119_) + local pairs_keys = nil + do + local _120_0 = nil do - local t = tbl - for _, k in ipairs(path) do - if (nil == t) then break end - local _127_ = type(t) - if (_127_ == "table") then - t = t[k] - else - t = nil + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for k in pairs(t) do + local val_19_ = k + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - _126_ = t - end - if (nil ~= _126_) then - local res = _126_ - return res - elseif true then - local _ = _126_ - return _3ffallback - else - return nil + _120_0 = tbl_17_ end + table.sort(_120_0, kv_compare) + pairs_keys = _120_0 end - end - local function map(t, f, _3fout) - local out = (_3fout or {}) - local f0 - if (type(f) == "function") then - f0 = f + local succ0, _, first_after_mt = add_stable_keys(succ, prev, pairs_keys) + local first = nil + if (first_mt == nil) then + first = first_after_mt else - local function _131_(_241) - return (_241)[f] - end - f0 = _131_ + first = first_mt end - for _, x in ipairs(t) do - local _133_ = f0(x) - if (nil ~= _133_) then - local v = _133_ - table.insert(out, v) + local function stablenext(tbl, key) + local _123_0 = nil + if (key == nil) then + _123_0 = first else + _123_0 = succ0[key] + end + if (nil ~= _123_0) then + local next_key = _123_0 + local _125_0 = tbl[next_key] + if (_125_0 ~= nil) then + return next_key, _125_0 + else + return _125_0 + end end end - return out + return stablenext, t, nil end - local function kvmap(t, f, _3fout) - local out = (_3fout or {}) - local f0 - if (type(f) == "function") then - f0 = f - else - local function _135_(_241) - return (_241)[f] - end - f0 = _135_ - end - for k, x in stablepairs(t) do - local _137_, _138_ = f0(k, x) - if ((nil ~= _137_) and (nil ~= _138_)) then - local key = _137_ - local value = _138_ - out[key] = value - elseif (nil ~= _137_) then - local value = _137_ - table.insert(out, value) - else + local function get_in(tbl, path) + if (nil ~= path[1]) then + local t = tbl + for _, k in ipairs(path) do + if (nil == t) then break end + if (type(t) == "table") then + t = t[k] + else + t = nil + end end + return t end - return out end - local function copy(from, _3fto) - local tbl_13_auto = (_3fto or {}) - for k, v in pairs((from or {})) do - local k_14_auto, v_15_auto = k, v - if ((k_14_auto ~= nil) and (v_15_auto ~= nil)) then - tbl_13_auto[k_14_auto] = v_15_auto - else + local function copy(_3ffrom, _3fto) + local tbl_14_ = (_3fto or {}) + for k, v in pairs((_3ffrom or {})) do + local k_15_, v_16_ = k, v + if ((k_15_ ~= nil) and (v_16_ ~= nil)) then + tbl_14_[k_15_] = v_16_ end end - return tbl_13_auto + return tbl_14_ end local function member_3f(x, tbl, _3fn) - local _141_ = tbl[(_3fn or 1)] - if (_141_ == x) then + local _131_0 = tbl[(_3fn or 1)] + if (_131_0 == x) then return true - elseif (_141_ == nil) then + elseif (_131_0 == nil) then return nil - elseif true then - local _ = _141_ - return member_3f(x, tbl, ((_3fn or 1) + 1)) else - return nil + local _ = _131_0 + return member_3f(x, tbl, ((_3fn or 1) + 1)) end end local function maxn(tbl) @@ -5230,9 +5626,9 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. end return max end - local function every_3f(predicate, seq) + local function every_3f(t, predicate) local result = true - for _, item in ipairs(seq) do + for _, item in ipairs(t) do if not result then break end result = predicate(item) end @@ -5250,17 +5646,13 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. seen[next_state] = true return next_state, value else - local _144_ = getmetatable(t) - if ((_G.type(_144_) == "table") and true) then - local __index = (_144_).__index + local _134_0 = getmetatable(t) + if ((_G.type(_134_0) == "table") and true) then + local __index = _134_0.__index if ("table" == type(__index)) then t = __index return allpairs_next(t) - else - return nil end - else - return nil end end end @@ -5269,23 +5661,26 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. local function deref(self) return self[1] end - local nil_sym = nil local function list__3estring(self, _3fview, _3foptions, _3findent) - local safe = {} - local view0 - if _3fview then - local function _148_(_241) - return _3fview(_241, _3foptions, _3findent) + local viewed = nil + do + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for i = 1, maxn(self) do + local val_19_ = nil + if _3fview then + val_19_ = _3fview(self[i], _3foptions, _3findent) + else + val_19_ = view(self[i]) + end + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end end - view0 = _148_ - else - view0 = view - end - local max = maxn(self) - for i = 1, max do - safe[i] = (((self[i] == nil) and nil_sym) or self[i]) + viewed = tbl_17_ end - return ("(" .. table.concat(map(safe, view0), " ", 1, max) .. ")") + return ("(" .. table.concat(viewed, " ") .. ")") end local function comment_view(c) return c, true @@ -5296,21 +5691,21 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. local function sym_3c(a, b) return (a[1] < tostring(b)) end - local symbol_mt = {__fennelview = deref, __tostring = deref, __eq = sym_3d, __lt = sym_3c, "SYMBOL"} - local expr_mt - local function _150_(x) + local symbol_mt = {"SYMBOL", __eq = sym_3d, __fennelview = deref, __lt = sym_3c, __tostring = deref} + local expr_mt = nil + local function _140_(x) return tostring(deref(x)) end - expr_mt = {__tostring = _150_, "EXPR"} - local list_mt = {__fennelview = list__3estring, __tostring = list__3estring, "LIST"} - local comment_mt = {__fennelview = comment_view, __tostring = deref, __eq = sym_3d, __lt = sym_3c, "COMMENT"} + expr_mt = {"EXPR", __tostring = _140_} + local list_mt = {"LIST", __fennelview = list__3estring, __tostring = list__3estring} + local comment_mt = {"COMMENT", __eq = sym_3d, __fennelview = comment_view, __lt = sym_3c, __tostring = deref} local sequence_marker = {"SEQUENCE"} - local varg_mt = {__fennelview = deref, __tostring = deref, "VARARG"} - local getenv - local function _151_() + local varg_mt = {"VARARG", __fennelview = deref, __tostring = deref} + local getenv = nil + local function _141_() return nil end - getenv = ((os and os.getenv) or _151_) + getenv = ((os and os.getenv) or _141_) local function debug_on_3f(flag) local level = (getenv("FENNEL_DEBUG") or "") return ((level == "all") or level:find(flag)) @@ -5319,67 +5714,63 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. return setmetatable({...}, list_mt) end local function sym(str, _3fsource) - local _152_ + local _142_ do - local tbl_13_auto = {str} + local tbl_14_ = {str} for k, v in pairs((_3fsource or {})) do - local k_14_auto, v_15_auto = nil, nil + local k_15_, v_16_ = nil, nil if (type(k) == "string") then - k_14_auto, v_15_auto = k, v + k_15_, v_16_ = k, v else - k_14_auto, v_15_auto = nil + k_15_, v_16_ = nil end - if ((k_14_auto ~= nil) and (v_15_auto ~= nil)) then - tbl_13_auto[k_14_auto] = v_15_auto - else + if ((k_15_ ~= nil) and (v_16_ ~= nil)) then + tbl_14_[k_15_] = v_16_ end end - _152_ = tbl_13_auto + _142_ = tbl_14_ end - return setmetatable(_152_, symbol_mt) + return setmetatable(_142_, symbol_mt) end - nil_sym = sym("nil") local function sequence(...) - local function _155_(seq, view0, inspector, indent) - local opts + local function _145_(seq, view0, inspector, indent) + local opts = nil do - local _156_ = inspector - _156_["empty-as-sequence?"] = {once = true, after = inspector["empty-as-sequence?"]} - _156_["metamethod?"] = {once = false, after = inspector["metamethod?"]} - opts = _156_ + inspector["empty-as-sequence?"] = {after = inspector["empty-as-sequence?"], once = true} + inspector["metamethod?"] = {after = inspector["metamethod?"], once = false} + opts = inspector end return view0(seq, opts, indent) end - return setmetatable({...}, {sequence = sequence_marker, __fennelview = _155_}) + return setmetatable({...}, {__fennelview = _145_, sequence = sequence_marker}) end local function expr(strcode, etype) - return setmetatable({type = etype, strcode}, expr_mt) + return setmetatable({strcode, type = etype}, expr_mt) end local function comment_2a(contents, _3fsource) - local _let_157_ = (_3fsource or {}) - local filename = _let_157_["filename"] - local line = _let_157_["line"] - return setmetatable({filename = filename, line = line, contents}, comment_mt) + local _146_ = (_3fsource or {}) + local filename = _146_["filename"] + local line = _146_["line"] + return setmetatable({contents, filename = filename, line = line}, comment_mt) end local function varg(_3fsource) - local _158_ + local _147_ do - local tbl_13_auto = {"..."} + local tbl_14_ = {"..."} for k, v in pairs((_3fsource or {})) do - local k_14_auto, v_15_auto = nil, nil + local k_15_, v_16_ = nil, nil if (type(k) == "string") then - k_14_auto, v_15_auto = k, v + k_15_, v_16_ = k, v else - k_14_auto, v_15_auto = nil + k_15_, v_16_ = nil end - if ((k_14_auto ~= nil) and (v_15_auto ~= nil)) then - tbl_13_auto[k_14_auto] = v_15_auto - else + if ((k_15_ ~= nil) and (v_16_ ~= nil)) then + tbl_14_[k_15_] = v_16_ end end - _158_ = tbl_13_auto + _147_ = tbl_14_ end - return setmetatable(_158_, varg_mt) + return setmetatable(_147_, varg_mt) end local function expr_3f(x) return ((type(x) == "table") and (getmetatable(x) == expr_mt) and x) @@ -5390,8 +5781,8 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. local function list_3f(x) return ((type(x) == "table") and (getmetatable(x) == list_mt) and x) end - local function sym_3f(x) - return ((type(x) == "table") and (getmetatable(x) == symbol_mt) and x) + local function sym_3f(x, _3fname) + return ((type(x) == "table") and (getmetatable(x) == symbol_mt) and ((nil == _3fname) or (x[1] == _3fname)) and x) end local function sequence_3f(x) local mt = ((type(x) == "table") and getmetatable(x)) @@ -5403,8 +5794,25 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. local function table_3f(x) return ((type(x) == "table") and not varg_3f(x) and (getmetatable(x) ~= list_mt) and (getmetatable(x) ~= symbol_mt) and not comment_3f(x) and x) end + local function kv_table_3f(t) + if table_3f(t) then + local nxt, t0, k = pairs(t) + local len0 = #t0 + local next_state = nil + if (0 == len0) then + next_state = k + else + next_state = len0 + end + return ((nil ~= nxt(t0, next_state)) and t0) + end + end local function string_3f(x) - return (type(x) == "string") + if (type(x) == "string") then + return x + else + return false + end end local function multi_sym_3f(str) if sym_3f(str) then @@ -5412,138 +5820,182 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. elseif (type(str) ~= "string") then return false else - local function _161_() + local function _153_() local parts = {} for part in str:gmatch("[^%.%:]+[%.%:]?") do - local last_char = part:sub(( - 1)) + local last_char = part:sub(-1) if (last_char == ":") then parts["multi-sym-method-call"] = true - else end if ((last_char == ":") or (last_char == ".")) then - parts[(#parts + 1)] = part:sub(1, ( - 2)) + parts[(#parts + 1)] = part:sub(1, -2) else parts[(#parts + 1)] = part end end - return ((0 < #parts) and parts) + return (next(parts) and parts) end - return ((str:match("%.") or str:match(":")) and not str:match("%.%.") and (str:byte() ~= string.byte(".")) and (str:byte(( - 1)) ~= string.byte(".")) and _161_()) + return ((str:match("%.") or str:match(":")) and not str:match("%.%.") and (str:byte() ~= string.byte(".")) and (str:byte() ~= string.byte(":")) and (str:byte(-1) ~= string.byte(".")) and (str:byte(-1) ~= string.byte(":")) and _153_()) end end + local function call_of_3f(ast, callee) + return (list_3f(ast) and sym_3f(ast[1], callee)) + end local function quoted_3f(symbol) return symbol.quoted end local function idempotent_expr_3f(x) - return ((type(x) == "string") or (type(x) == "integer") or (type(x) == "number") or (sym_3f(x) and not multi_sym_3f(x))) - end - local function ast_source(ast) - if (table_3f(ast) or sequence_3f(ast)) then - return (getmetatable(ast) or {}) - elseif ("table" == type(ast)) then - return ast - else - return {} - end + local t = type(x) + return ((t == "string") or (t == "number") or (t == "boolean") or (sym_3f(x) and not multi_sym_3f(x))) end local function walk_tree(root, f, _3fcustom_iterator) local function walk(iterfn, parent, idx, node) - if f(idx, node, parent) then + if (f(idx, node, parent) and not sym_3f(node)) then for k, v in iterfn(node) do walk(iterfn, node, k, v) end return nil - else - return nil end end walk((_3fcustom_iterator or pairs), nil, nil, root) return root end - local lua_keywords = {"and", "break", "do", "else", "elseif", "end", "false", "for", "function", "if", "in", "local", "nil", "not", "or", "repeat", "return", "then", "true", "until", "while", "goto"} - for i, v in ipairs(lua_keywords) do - lua_keywords[v] = i + local root = nil + local function _158_() + end + root = {chunk = nil, options = nil, reset = _158_, scope = nil} + root["set-reset"] = function(_159_0) + local _160_ = _159_0 + local chunk = _160_["chunk"] + local options = _160_["options"] + local reset = _160_["reset"] + local scope = _160_["scope"] + root.reset = function() + root.chunk, root.scope, root.options, root.reset = chunk, scope, options, reset + return nil + end + return root.reset + end + local lua_keywords = {["and"] = true, ["break"] = true, ["do"] = true, ["else"] = true, ["elseif"] = true, ["end"] = true, ["false"] = true, ["for"] = true, ["function"] = true, ["goto"] = true, ["if"] = true, ["in"] = true, ["local"] = true, ["nil"] = true, ["not"] = true, ["or"] = true, ["repeat"] = true, ["return"] = true, ["then"] = true, ["true"] = true, ["until"] = true, ["while"] = true} + local function lua_keyword_3f(str) + local function _162_() + local _161_0 = root.options + if (nil ~= _161_0) then + _161_0 = _161_0.keywords + end + if (nil ~= _161_0) then + _161_0 = _161_0[str] + end + return _161_0 + end + return (lua_keywords[str] or _162_()) end local function valid_lua_identifier_3f(str) - return (str:match("^[%a_][%w_]*$") and not lua_keywords[str]) + return (str:match("^[%a_][%w_]*$") and not lua_keyword_3f(str)) end local propagated_options = {"allowedGlobals", "indent", "correlate", "useMetadata", "env", "compiler-env", "compilerEnv"} local function propagate_options(options, subopts) + local tbl_14_ = subopts for _, name in ipairs(propagated_options) do - subopts[name] = options[name] + local k_15_, v_16_ = name, options[name] + if ((k_15_ ~= nil) and (v_16_ ~= nil)) then + tbl_14_[k_15_] = v_16_ + end end - return subopts + return tbl_14_ end - local root - local function _167_() + local function ast_source(ast) + if (table_3f(ast) or sequence_3f(ast)) then + return (getmetatable(ast) or {}) + elseif ("table" == type(ast)) then + return ast + else + return {} + end end - root = {chunk = nil, scope = nil, options = nil, reset = _167_} - root["set-reset"] = function(_168_) - local _arg_169_ = _168_ - local chunk = _arg_169_["chunk"] - local scope = _arg_169_["scope"] - local options = _arg_169_["options"] - local reset = _arg_169_["reset"] - root.reset = function() - root.chunk, root.scope, root.options, root.reset = chunk, scope, options, reset - return nil + local function warn(msg, _3fast, _3ffilename, _3fline) + local _167_0 = nil + do + local _168_0 = root.options + if (nil ~= _168_0) then + _168_0 = _168_0.warn + end + _167_0 = _168_0 + end + if (nil ~= _167_0) then + local opt_warn = _167_0 + return opt_warn(msg, _3fast, _3ffilename, _3fline) + else + local _ = _167_0 + if (_G.io and _G.io.stderr) then + local loc = nil + do + local _170_0 = ast_source(_3fast) + if ((_G.type(_170_0) == "table") and (nil ~= _170_0.filename) and (nil ~= _170_0.line)) then + local filename = _170_0.filename + local line = _170_0.line + loc = (filename .. ":" .. line .. ": ") + else + local _0 = _170_0 + if (_3ffilename and _3fline) then + loc = (_3ffilename .. ":" .. _3fline .. ": ") + else + loc = "" + end + end + end + return (_G.io.stderr):write(("--WARNING: %s%s\n"):format(loc, msg)) + end end - return root.reset end local warned = {} - local function check_plugin_version(_170_) - local _arg_171_ = _170_ - local name = _arg_171_["name"] - local versions = _arg_171_["versions"] - local plugin = _arg_171_ - if (not member_3f(version:gsub("-dev", ""), (versions or {})) and not warned[plugin]) then + local function check_plugin_version(_175_0) + local _176_ = _175_0 + local plugin = _176_ + local name = _176_["name"] + local versions = _176_["versions"] + if (not member_3f(version:gsub("-dev", ""), (versions or {})) and not (string_3f(versions) and version:find(versions)) and not warned[plugin]) then warned[plugin] = true return warn(string.format("plugin %s does not support Fennel version %s", (name or "unknown"), version)) - else - return nil end end local function hook_opts(event, _3foptions, ...) - local plugins - local function _174_(...) - local t_173_ = _3foptions - if (nil ~= t_173_) then - t_173_ = (t_173_).plugins - else + local plugins = nil + local function _179_(...) + local _178_0 = _3foptions + if (nil ~= _178_0) then + _178_0 = _178_0.plugins end - return t_173_ + return _178_0 end - local function _177_(...) - local t_176_ = root.options - if (nil ~= t_176_) then - t_176_ = (t_176_).plugins - else + local function _182_(...) + local _181_0 = root.options + if (nil ~= _181_0) then + _181_0 = _181_0.plugins end - return t_176_ + return _181_0 end - plugins = (_174_(...) or _177_(...)) + plugins = (_179_(...) or _182_(...)) if plugins then local result = nil for _, plugin in ipairs(plugins) do - if result then break end + if (nil ~= result) then break end check_plugin_version(plugin) - local _179_ = plugin[event] - if (nil ~= _179_) then - local f = _179_ + local _184_0 = plugin[event] + if (nil ~= _184_0) then + local f = _184_0 result = f(...) else - result = nil + result = nil end end return result - else - return nil end end local function hook(event, ...) return hook_opts(event, root.options, ...) end - return {warn = warn, allpairs = allpairs, stablepairs = stablepairs, copy = copy, ["get-in"] = get_in, kvmap = kvmap, map = map, ["walk-tree"] = walk_tree, ["member?"] = member_3f, maxn = maxn, ["every?"] = every_3f, list = list, sequence = sequence, sym = sym, varg = varg, expr = expr, comment = comment_2a, ["comment?"] = comment_3f, ["expr?"] = expr_3f, ["list?"] = list_3f, ["multi-sym?"] = multi_sym_3f, ["sequence?"] = sequence_3f, ["sym?"] = sym_3f, ["table?"] = table_3f, ["varg?"] = varg_3f, ["quoted?"] = quoted_3f, ["string?"] = string_3f, ["idempotent-expr?"] = idempotent_expr_3f, ["valid-lua-identifier?"] = valid_lua_identifier_3f, ["lua-keywords"] = lua_keywords, hook = hook, ["hook-opts"] = hook_opts, ["propagate-options"] = propagate_options, root = root, ["debug-on?"] = debug_on_3f, ["ast-source"] = ast_source, version = version, ["runtime-version"] = runtime_version, len = len, path = table.concat({"./?.fnl", "./?/init.fnl", getenv("FENNEL_PATH")}, ";"), ["macro-path"] = table.concat({"./?.fnl", "./?/init-macros.fnl", "./?/init.fnl", getenv("FENNEL_MACRO_PATH")}, ";")} + return {["ast-source"] = ast_source, ["call-of?"] = call_of_3f, ["comment?"] = comment_3f, ["debug-on?"] = debug_on_3f, ["every?"] = every_3f, ["expr?"] = expr_3f, ["fennel-module"] = nil, ["get-in"] = get_in, ["hook-opts"] = hook_opts, ["idempotent-expr?"] = idempotent_expr_3f, ["kv-table?"] = kv_table_3f, ["list?"] = list_3f, ["lua-keyword?"] = lua_keyword_3f, ["macro-path"] = table.concat({"./?.fnl", "./?/init-macros.fnl", "./?/init.fnl", getenv("FENNEL_MACRO_PATH")}, ";"), ["member?"] = member_3f, ["multi-sym?"] = multi_sym_3f, ["propagate-options"] = propagate_options, ["quoted?"] = quoted_3f, ["runtime-version"] = runtime_version, ["sequence?"] = sequence_3f, ["string?"] = string_3f, ["sym?"] = sym_3f, ["table?"] = table_3f, ["valid-lua-identifier?"] = valid_lua_identifier_3f, ["varg?"] = varg_3f, ["walk-tree"] = walk_tree, allpairs = allpairs, comment = comment_2a, copy = copy, expr = expr, hook = hook, len = len, list = list, maxn = maxn, path = table.concat({"./?.fnl", "./?/init.fnl", getenv("FENNEL_PATH")}, ";"), root = root, sequence = sequence, stablepairs = stablepairs, sym = sym, varg = varg, version = version, warn = warn} end package.preload["fennel"] = package.preload["fennel"] or function(...) local utils = require("fennel.utils") @@ -5557,7 +6009,6 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) local env0 = specials["make-compiler-env"](nil, compiler.scopes.compiler, {}, opts) if (opts.allowedGlobals == nil) then opts.allowedGlobals = specials["current-global-names"](env0) - else end return specials["wrap-env"](env0) else @@ -5568,36 +6019,33 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) local opts = utils.copy(options) if (opts.allowedGlobals == nil) then opts.allowedGlobals = specials["current-global-names"](opts.env) - else end if (not opts.filename and not opts.source) then opts.source = str - else end if (opts.env == "_COMPILER") then opts.scope = compiler["make-scope"](compiler.scopes.compiler) - else end return opts end - local function eval(str, options, ...) - local opts = eval_opts(options, str) + local function eval(str, _3foptions, ...) + local opts = eval_opts(_3foptions, str) local env = eval_env(opts.env, opts) local lua_source = compiler["compile-string"](str, opts) - local loader - local function _753_(...) + local loader = nil + local function _841_(...) if opts.filename then return ("@" .. opts.filename) else return str end end - loader = specials["load-code"](lua_source, env, _753_(...)) + loader = specials["load-code"](lua_source, env, _841_(...)) opts.filename = nil return loader(...) end - local function dofile_2a(filename, options, ...) - local opts = utils.copy(options) + local function dofile_2a(filename, _3foptions, ...) + local opts = utils.copy(_3foptions) local f = assert(io.open(filename, "rb")) local source = assert(f:read("*all"), ("Could not read " .. filename)) f:close() @@ -5608,32 +6056,33 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) local body_3f = {"when", "with-open", "collect", "icollect", "fcollect", "lambda", "\206\187", "macro", "match", "match-try", "case", "case-try", "accumulate", "faccumulate", "doto"} local binding_3f = {"collect", "icollect", "fcollect", "each", "for", "let", "with-open", "accumulate", "faccumulate"} local define_3f = {"fn", "lambda", "\206\187", "var", "local", "macro", "macros", "global"} + local deprecated = {"~=", "#", "global", "require-macros", "pick-args"} local out = {} for k, v in pairs(compiler.scopes.global.specials) do local metadata = (compiler.metadata[v] or {}) - do end (out)[k] = {["special?"] = true, ["body-form?"] = metadata["fnl/body-form?"], ["binding-form?"] = utils["member?"](k, binding_3f), ["define?"] = utils["member?"](k, define_3f)} + out[k] = {["binding-form?"] = utils["member?"](k, binding_3f), ["body-form?"] = metadata["fnl/body-form?"], ["define?"] = utils["member?"](k, define_3f), ["deprecated?"] = utils["member?"](k, deprecated), ["special?"] = true} end - for k, v in pairs(compiler.scopes.global.macros) do - out[k] = {["macro?"] = true, ["body-form?"] = utils["member?"](k, body_3f), ["binding-form?"] = utils["member?"](k, binding_3f), ["define?"] = utils["member?"](k, define_3f)} + for k in pairs(compiler.scopes.global.macros) do + out[k] = {["binding-form?"] = utils["member?"](k, binding_3f), ["body-form?"] = utils["member?"](k, body_3f), ["define?"] = utils["member?"](k, define_3f), ["macro?"] = true} end for k, v in pairs(_G) do - local _754_ = type(v) - if (_754_ == "function") then - out[k] = {["global?"] = true, ["function?"] = true} - elseif (_754_ == "table") then - for k2, v2 in pairs(v) do - if (("function" == type(v2)) and (k ~= "_G")) then - out[(k .. "." .. k2)] = {["function?"] = true, ["global?"] = true} - else + local _842_0 = type(v) + if (_842_0 == "function") then + out[k] = {["function?"] = true, ["global?"] = true} + elseif (_842_0 == "table") then + if not k:find("^_") then + for k2, v2 in pairs(v) do + if ("function" == type(v2)) then + out[(k .. "." .. k2)] = {["function?"] = true, ["global?"] = true} + end end + out[k] = {["global?"] = true} end - out[k] = {["global?"] = true} - else end end return out end - local mod = {list = utils.list, ["list?"] = utils["list?"], sym = utils.sym, ["sym?"] = utils["sym?"], ["multi-sym?"] = utils["multi-sym?"], sequence = utils.sequence, ["sequence?"] = utils["sequence?"], ["table?"] = utils["table?"], comment = utils.comment, ["comment?"] = utils["comment?"], varg = utils.varg, ["varg?"] = utils["varg?"], ["sym-char?"] = parser["sym-char?"], parser = parser.parser, compile = compiler.compile, ["compile-string"] = compiler["compile-string"], ["compile-stream"] = compiler["compile-stream"], eval = eval, repl = repl, view = view, dofile = dofile_2a, ["load-code"] = specials["load-code"], doc = specials.doc, metadata = compiler.metadata, traceback = compiler.traceback, version = utils.version, ["runtime-version"] = utils["runtime-version"], ["ast-source"] = utils["ast-source"], path = utils.path, ["macro-path"] = utils["macro-path"], ["macro-loaded"] = specials["macro-loaded"], ["macro-searchers"] = specials["macro-searchers"], ["search-module"] = specials["search-module"], ["make-searcher"] = specials["make-searcher"], searcher = specials["make-searcher"](), syntax = syntax, gensym = compiler.gensym, scope = compiler["make-scope"], mangle = compiler["global-mangling"], unmangle = compiler["global-unmangling"], compile1 = compiler.compile1, ["string-stream"] = parser["string-stream"], granulate = parser.granulate, loadCode = specials["load-code"], make_searcher = specials["make-searcher"], makeSearcher = specials["make-searcher"], searchModule = specials["search-module"], macroPath = utils["macro-path"], macroSearchers = specials["macro-searchers"], macroLoaded = specials["macro-loaded"], compileStream = compiler["compile-stream"], compileString = compiler["compile-string"], stringStream = parser["string-stream"], runtimeVersion = utils["runtime-version"]} + local mod = {["ast-source"] = utils["ast-source"], ["comment?"] = utils["comment?"], ["compile-stream"] = compiler["compile-stream"], ["compile-string"] = compiler["compile-string"], ["list?"] = utils["list?"], ["load-code"] = specials["load-code"], ["macro-loaded"] = specials["macro-loaded"], ["macro-path"] = utils["macro-path"], ["macro-searchers"] = specials["macro-searchers"], ["make-searcher"] = specials["make-searcher"], ["multi-sym?"] = utils["multi-sym?"], ["runtime-version"] = utils["runtime-version"], ["search-module"] = specials["search-module"], ["sequence?"] = utils["sequence?"], ["string-stream"] = parser["string-stream"], ["sym-char?"] = parser["sym-char?"], ["sym?"] = utils["sym?"], ["table?"] = utils["table?"], ["varg?"] = utils["varg?"], 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, getinfo = compiler.getinfo, granulate = parser.granulate, list = utils.list, loadCode = specials["load-code"], macroLoaded = specials["macro-loaded"], macroPath = utils["macro-path"], macroSearchers = specials["macro-searchers"], makeSearcher = specials["make-searcher"], make_searcher = specials["make-searcher"], mangle = compiler["global-mangling"], metadata = compiler.metadata, parser = parser.parser, path = utils.path, repl = repl, runtimeVersion = utils["runtime-version"], scope = compiler["make-scope"], searchModule = specials["search-module"], searcher = specials["make-searcher"](), sequence = utils.sequence, stringStream = parser["string-stream"], sym = utils.sym, syntax = syntax, traceback = compiler.traceback, unmangle = compiler["global-unmangling"], varg = utils.varg, version = utils.version, view = view} mod.install = function(_3fopts) table.insert((package.searchers or package.loaders), specials["make-searcher"](_3fopts)) return mod @@ -5641,20 +6090,23 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) utils["fennel-module"] = mod do local module_name = "fennel.macros" - local _ - local function _757_() + local _ = nil + local function _846_() return mod end - package.preload[module_name] = _757_ + package.preload[module_name] = _846_ _ = nil - local env + local env = nil do - local _758_ = specials["make-compiler-env"](nil, compiler.scopes.compiler, {}) - do end (_758_)["utils"] = utils - _758_["fennel"] = mod - env = _758_ + local _847_0 = specials["make-compiler-env"](nil, compiler.scopes.compiler, {}) + _847_0["utils"] = utils + _847_0["fennel"] = mod + _847_0["get-function-metadata"] = specials["get-function-metadata"] + env = _847_0 end - local built_ins = eval([===[;; These macros are awkward because their definition cannot rely on the any + local built_ins = eval([===[;; fennel-ls: macro-file + + ;; These macros are awkward because their definition cannot rely on the any ;; built-in macros, only special forms. (no when, no icollect, etc) (fn copy [t] @@ -5689,26 +6141,28 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) Same as -> except will short-circuit with nil when it encounters a nil value." (if (= nil ?e) val - (let [el (if (list? ?e) (copy ?e) (list ?e)) - tmp (gensym)] - (table.insert el 2 tmp) - `(let [,tmp ,val] - (if (not= nil ,tmp) - (-?> ,el ,...) - ,tmp))))) + (not (utils.idempotent-expr? val)) + ;; try again, but with an eval-safe val + `(let [tmp# ,val] + (-?> tmp# ,?e ,...)) + (let [call (if (list? ?e) (copy ?e) (list ?e))] + (table.insert call 2 val) + `(if (not= nil ,val) + ,(-?>* call ...))))) (fn -?>>* [val ?e ...] "Nil-safe thread-last macro. Same as ->> except will short-circuit with nil when it encounters a nil value." (if (= nil ?e) val - (let [el (if (list? ?e) (copy ?e) (list ?e)) - tmp (gensym)] - (table.insert el tmp) - `(let [,tmp ,val] - (if (not= ,tmp nil) - (-?>> ,el ,...) - ,tmp))))) + (not (utils.idempotent-expr? val)) + ;; try again, but with an eval-safe val + `(let [tmp# ,val] + (-?>> tmp# ,?e ,...)) + (let [call (if (list? ?e) (copy ?e) (list ?e))] + (table.insert call val) + `(if (not= ,val nil) + ,(-?>>* call ...))))) (fn ?dot [tbl ...] "Nil-safe table look up. @@ -5718,26 +6172,26 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) lookups `(do (var ,head ,tbl) ,head)] - (each [_ k (ipairs [...])] + (each [i k (ipairs [...])] ;; Kinda gnarly to reassign in place like this, but it emits the best lua. ;; With this impl, it emits a flat, concise, and readable set of ifs - (table.insert lookups (# lookups) `(if (not= nil ,head) - (set ,head (. ,head ,k))))) + (table.insert lookups (+ i 2) + `(if (not= nil ,head) (set ,head (. ,head ,k))))) lookups)) (fn doto* [val ...] "Evaluate val and splice it into the first argument of subsequent forms." (assert (not= val nil) "missing subject") - (let [rebind? (or (not (sym? val)) - (multi-sym? val)) - name (if rebind? (gensym) val) - form (if rebind? `(let [,name ,val]) `(do))] - (each [_ elt (ipairs [...])] - (let [elt (if (list? elt) (copy elt) (list elt))] - (table.insert elt 2 name) - (table.insert form elt))) - (table.insert form name) - form)) + (if (not (utils.idempotent-expr? val)) + `(let [tmp# ,val] + (doto tmp# ,...)) + (let [form `(do)] + (each [_ elt (ipairs [...])] + (let [elt (if (list? elt) (copy elt) (list elt))] + (table.insert elt 2 val) + (table.insert form elt))) + (table.insert form val) + form))) (fn when* [condition body1 ...] "Evaluate body for side-effects only when condition is truthy." @@ -5755,7 +6209,8 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) ,...) closer `(fn close-handlers# [ok# ...] (if ok# ... (error ... 0))) - traceback `(. (or package.loaded.fennel debug) :traceback)] + traceback `(. (or (. package.loaded ,(fennel-module-name)) _G.debug {}) + :traceback)] (for [i 1 (length closable-bindings) 2] (assert (sym? (. closable-bindings i)) "with-open only allows symbols in bindings") @@ -5768,8 +6223,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) (var (into iter-out found?) (values [] (copy iter-tbl))) (for [i (length iter-tbl) 2 -1] (let [item (. iter-tbl i)] - (if (or (= `&into item) - (= :into item)) + (if (or (sym? item "&into") (= :into item)) (do (assert (not found?) "expected only one &into clause") (set found? true) @@ -5778,7 +6232,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) (table.remove iter-out i))))) (assert (or (not found?) (sym? into) (table? into) (list? into)) "expected table, function call, or symbol in &into clause") - (values into iter-out)) + (values into iter-out found?)) (fn collect* [iter-tbl key-expr value-expr ...] "Return a table made by running an iterator and evaluating an expression that @@ -5799,6 +6253,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) (assert (not= nil key-expr) "expected key and value expression") (assert (= nil ...) "expected 1 or 2 body expressions; wrap multiple expressions with do") + (assert (or value-expr (list? key-expr)) "need key and value") (let [kv-expr (if (= nil value-expr) key-expr `(values ,key-expr ,value-expr)) (into iter) (extract-into iter-tbl)] `(let [tbl# ,into] @@ -5816,17 +6271,23 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) (assert (not= nil value-expr) "expected table value expression") (assert (= nil ...) "expected exactly one body expression. Wrap multiple expressions in do") - (let [(into iter) (extract-into iter-tbl)] - `(let [tbl# ,into] - ;; believe it or not, using a var here has a pretty good performance - ;; boost: https://p.hagelb.org/icollect-performance.html - (var i# (length tbl#)) - (,how ,iter - (let [val# ,value-expr] - (when (not= nil val#) - (set i# (+ i# 1)) - (tset tbl# i# val#)))) - tbl#))) + (let [(into iter has-into?) (extract-into iter-tbl)] + (if has-into? + `(let [tbl# ,into] + (,how ,iter (let [val# ,value-expr] + (table.insert tbl# val#))) + tbl#) + ;; believe it or not, using a var here has a pretty good performance + ;; boost: https://p.hagelb.org/icollect-performance.html + ;; but it doesn't always work with &into clauses, so skip if that's used + `(let [tbl# []] + (var i# 0) + (,how ,iter + (let [val# ,value-expr] + (when (not= nil val#) + (set i# (+ i# 1)) + (tset tbl# i# val#)))) + tbl#)))) (fn icollect* [iter-tbl value-expr ...] "Return a sequential table made by running an iterator and evaluating an @@ -5906,17 +6367,13 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) numerical range like `for` rather than an iterator." (accumulate-impl true iter-tbl body ...)) - (fn double-eval-safe? [x type] - (or (= :number type) (= :string type) (= :boolean type) - (and (sym? x) (not (multi-sym? x))))) - (fn partial* [f ...] "Return a function with all arguments partially applied to f." (assert f "expected a function to partially apply") (let [bindings [] args []] (each [_ arg (ipairs [...])] - (if (double-eval-safe? arg (type arg)) + (if (utils.idempotent-expr? arg) (table.insert args arg) (let [name (gensym)] (table.insert bindings name) @@ -5925,68 +6382,39 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) (let [body (list f (unpack args))] (table.insert body _VARARG) ;; only use the extra let if we need double-eval protection - (if (= 0 (length bindings)) + (if (= nil (. bindings 1)) `(fn [,_VARARG] ,body) `(let ,bindings (fn [,_VARARG] ,body)))))) (fn pick-args* [n f] - "Create a function of arity n that applies its arguments to f. - - For example, - (pick-args 2 func) - expands to - (fn [_0_ _1_] (func _0_ _1_))" + "Create a function of arity n that applies its arguments to f. Deprecated." (if (and _G.io _G.io.stderr) (_G.io.stderr:write "-- WARNING: pick-args is deprecated and will be removed in the future.\n")) - (assert (and (= (type n) :number) (= n (math.floor n)) (<= 0 n)) - (.. "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))))) - - (fn pick-values* [n ...] - "Evaluate to exactly n values. - - For example, - (pick-values 2 ...) - expands to - (let [(_0_ _1_) ...] - (values _0_ _1_))" - (assert (and (= :number (type n)) (<= 0 n) (= n (math.floor n))) - (.. "Expected n to be an integer >= 0, got " (tostring n))) - (let [let-syms (list) - let-values (if (= 1 (select "#" ...)) ... `(values ,...))] - (for [i 1 n] - (table.insert let-syms (gensym))) - (if (= n 0) `(values) - `(let [,let-syms ,let-values] - (values ,(unpack let-syms)))))) + (for [i 1 n] (tset bindings i (gensym))) + `(fn ,bindings (,f ,(unpack bindings))))) (fn lambda* [...] "Function literal with nil-checked arguments. Like `fn`, but will throw an exception if a declared argument is passed in as nil, unless that argument's name begins with a question mark." (let [args [...] + args-len (length args) has-internal-name? (sym? (. args 1)) arglist (if has-internal-name? (. args 2) (. args 1)) - docstring-position (if has-internal-name? 3 2) - has-docstring? (and (< docstring-position (length args)) - (= :string (type (. args docstring-position)))) - arity-check-position (- 4 (if has-internal-name? 0 1) - (if has-docstring? 0 1)) - empty-body? (< (length args) arity-check-position)] + metadata-position (if has-internal-name? 3 2) + (_ check-position) (get-function-metadata [:lambda ...] arglist + metadata-position) + empty-body? (< args-len check-position)] (fn check! [a] (if (table? a) - (each [_ a (pairs a)] - (check! a)) + (each [_ a (pairs a)] (check! a)) (let [as (tostring a)] - (and (not (as:match "^?")) (not= as "&") (not= as "_") + (and (not (as:find "^?")) (not= as "&") (not (as:find "^_")) (not= as "...") (not= as "&as"))) - (table.insert args arity-check-position + (table.insert args check-position `(_G.assert (not= nil ,a) ,(: "Missing argument %s on %s:%s" :format (tostring a) @@ -5994,10 +6422,8 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) (or a.line "?")))))) (assert (= :table (type arglist)) "expected arg list") - (each [_ a (ipairs arglist)] - (check! a)) - (if empty-body? - (table.insert args (sym :nil))) + (each [_ a (ipairs arglist)] (check! a)) + (if empty-body? (table.insert args (sym :nil))) `(fn ,(unpack args)))) (fn macro* [name ...] @@ -6010,7 +6436,9 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) "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))))) + ;; TODO: Provide a helpful compiler error in the unlikely edge case of an + ;; infinite AST instead of the current "silently expand until max depth" + `(,handle ,(view (macroexpand form _SCOPE) {:detect-cycles? false})))) (fn import-macros* [binding1 module-name1 ...] "Bind a table of macros from each macro module according to a binding form. @@ -6045,6 +6473,32 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) (tset scope.macros import-key (. macros* macro-name)))))) nil) + (fn assert-repl* [condition ...] + "Enter into a debug REPL and print the message when condition is false/nil. + Works as a drop-in replacement for Lua's `assert`. + REPL `,return` command returns values to assert in place to continue execution." + {:fnl/arglist [condition ?message ...]} + (fn add-locals [{: symmeta : parent} locals] + (each [name (pairs symmeta)] + (tset locals name (sym name))) + (if parent (add-locals parent locals) locals)) + `(let [unpack# (or table.unpack _G.unpack) + pack# (or table.pack #(doto [$...] (tset :n (select :# $...)))) + ;; need to pack/unpack input args to account for (assert (foo)), + ;; because assert returns *all* arguments upon success + vals# (pack# ,condition ,...) + condition# (. vals# 1) + message# (or (. vals# 2) "assertion failed, entering repl.")] + (if (not condition#) + (let [opts# {:assert-repl? true} + fennel# (require ,(fennel-module-name)) + locals# ,(add-locals (get-scope) [])] + (set opts#.message (fennel#.traceback message#)) + (set opts#.env (collect [k# v# (pairs _G) &into locals#] + (if (= nil (. locals# k#)) (values k# v#)))) + (_G.assert (fennel#.repl opts#))) + (values (unpack# vals# 1 vals#.n))))) + {:-> ->* :->> ->>* :-?> -?>* @@ -6060,24 +6514,30 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) :faccumulate faccumulate* :partial partial* :lambda lambda* - :λ lambda* + :λ lambda* :pick-args pick-args* - :pick-values pick-values* :macro macro* :macrodebug macrodebug* - :import-macros import-macros*} - ]===], {env = env, scope = compiler.scopes.compiler, useMetadata = true, filename = "src/fennel/macros.fnl", moduleName = module_name}) - local _0 + :import-macros import-macros* + :assert-repl assert-repl*} + ]===], {env = env, filename = "src/fennel/macros.fnl", moduleName = module_name, scope = compiler.scopes.compiler, useMetadata = true}) + local _0 = nil for k, v in pairs(built_ins) do compiler.scopes.global.macros[k] = v end _0 = nil - local match_macros = eval([===[;;; Pattern matching + local match_macros = eval([===[;; fennel-ls: macro-file + + ;;; Pattern matching ;; This is separated out so we can use the "core" macros during the ;; implementation of pattern matching. (fn copy [t] (collect [k v (pairs t)] k v)) + (fn double-eval-safe? [x type] + (or (= :number type) (= :string type) (= :boolean type) + (and (sym? x) (not (multi-sym? x))))) + (fn with [opts k] (doto (copy opts) (tset k true))) @@ -6094,11 +6554,11 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) (icollect [_ b (ipairs subbindings) &into bindings] b))) (values condition bindings))) - (fn case-table [val pattern unifications case-pattern opts] - (let [condition `(and (= (_G.type ,val) :table)) + (fn case-table [val pattern unifications case-pattern opts ?top] + (let [condition (if (= :table ?top) `(and) `(and (= (_G.type ,val) :table))) bindings []] (each [k pat (pairs pattern)] - (if (= pat `&) + (if (sym? pat :&) (let [rest-pat (. pattern (+ k 1)) rest-val `(select ,k ((or table.unpack _G.unpack) ,val)) subcondition (case-table `(pick-values 1 ,rest-val) @@ -6110,19 +6570,19 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) "expected & rest argument before last parameter") (table.insert bindings rest-pat) (table.insert bindings [rest-val])) - (= k `&as) + (sym? k :&as) (do (table.insert bindings pat) (table.insert bindings val)) - (and (= :number (type k)) (= `&as pat)) + (and (= :number (type k)) (sym? pat :&as)) (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))))) + (or (not= :number (type k)) (and (not (sym? (. pattern (- k 1)) :&as)) + (not (sym? (. pattern (- k 1)) :&)))) (let [subval `(. ,val ,k) (subcondition subbindings) (case-pattern [subval] pat unifications @@ -6132,27 +6592,30 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) (values condition bindings))) (fn case-guard [vals condition guards unifications case-pattern opts] - (if (= 0 (length guards)) - (case-pattern vals condition unifications opts) + (if (. guards 1) (let [(pcondition bindings) (case-pattern vals condition unifications opts) condition `(and ,(unpack guards))] (values `(and ,pcondition (let ,bindings - ,condition)) bindings)))) + ,condition)) bindings)) + (case-pattern vals condition unifications opts))) (fn symbols-in-pattern [pattern] "gives the set of symbols inside a pattern" (if (list? pattern) - (let [result {}] - (each [_ child-pattern (ipairs pattern)] - (collect [name symbol (pairs (symbols-in-pattern child-pattern)) &into result] - name symbol)) - result) + (if (or (sym? (. pattern 1) :where) + (sym? (. pattern 1) :=)) + (symbols-in-pattern (. pattern 2)) + (sym? (. pattern 2) :?) + (symbols-in-pattern (. pattern 1)) + (let [result {}] + (each [_ child-pattern (ipairs pattern)] + (collect [name symbol (pairs (symbols-in-pattern child-pattern)) &into result] + name symbol)) + result)) (sym? pattern) - (if (and (not= pattern `or) - (not= pattern `where) - (not= pattern `?) - (not= pattern `nil)) + (if (and (not (sym? pattern :or)) + (not (sym? pattern :nil))) {(tostring pattern) pattern} {}) (= (type pattern) :table) @@ -6172,7 +6635,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) (let [in-pattern (symbols-in-pattern pattern)] (if ?symbols (do - (each [name symbol (pairs ?symbols)] + (each [name (pairs ?symbols)] (when (not (. in-pattern name)) (tset ?symbols name nil))) ?symbols) @@ -6184,24 +6647,21 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) (fn case-or [vals pattern guards unifications case-pattern opts] (let [pattern [(unpack pattern 2)] - bindings (symbols-in-every-pattern pattern opts.infer-unification?)] ;; TODO opts.infer-unification instead of opts.unification? - (if (= 0 (length bindings)) - ;; no bindings special case generates simple code - (let [condition - (icollect [i subpattern (ipairs pattern) &into `(or)] - (let [(subcondition subbindings) (case-pattern vals subpattern unifications opts)] - subcondition))] - (values - (if (= 0 (length guards)) - condition - `(and ,condition ,(unpack guards))) - [])) + bindings (symbols-in-every-pattern pattern opts.infer-unification?)] + (if (= nil (. bindings 1)) + ;; no bindings special case generates simple code + (let [condition (icollect [_ subpattern (ipairs pattern) &into `(or)] + (case-pattern vals subpattern unifications opts))] + (values (if (. guards 1) + `(and ,condition ,(unpack guards)) + condition) + [])) ;; case with bindings is handled specially, and returns three values instead of two (let [matched? (gensym :matched?) bindings-mangled (icollect [_ binding (ipairs bindings)] (gensym (tostring binding))) pre-bindings `(if)] - (each [i subpattern (ipairs pattern)] + (each [_ subpattern (ipairs pattern)] (let [(subcondition subbindings) (case-guard vals subpattern guards {} case-pattern opts)] (table.insert pre-bindings subcondition) (table.insert pre-bindings `(let ,subbindings @@ -6210,7 +6670,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) [`(,(unpack bindings)) `(values ,(unpack bindings-mangled))] [`(,matched? ,(unpack bindings-mangled)) pre-bindings]))))) - (fn case-pattern [vals pattern unifications opts top-level?] + (fn case-pattern [vals pattern unifications opts ?top] "Take the AST of values and a single pattern and returns a condition to determine if it matches as well as a list of bindings to introduce for the duration of the body if it does match." @@ -6235,10 +6695,10 @@ 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 (and (sym? pattern) - (or (= pattern `nil) + (or (sym? pattern :nil) (and opts.infer-unification? (in-scope? pattern) - (not= pattern `_)) + (not (sym? pattern :_))) (and opts.infer-unification? (multi-sym? pattern) (in-scope? (. (multi-sym? pattern) 1))))) @@ -6254,33 +6714,33 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) `(not= ,(sym :nil) ,val)) [pattern val])) ;; opt-in unify with (=) (and (list? pattern) - (= (. pattern 1) `=) + (sym? (. pattern 1) :=) (sym? (. pattern 2))) (let [bind (. pattern 2)] (assert-compile (= 2 (length pattern)) "(=) should take only one argument" pattern) (assert-compile (not opts.infer-unification?) "(=) cannot be used inside of match" pattern) (assert-compile opts.in-where? "(=) must be used in (where) patterns" pattern) - (assert-compile (and (sym? bind) (not= bind `nil) "= has to bind to a symbol" bind)) + (assert-compile (and (sym? bind) (not (sym? bind :nil)) "= has to bind to a symbol" bind)) (values `(= ,val ,bind) [])) ;; where-or clause - (and (list? pattern) (= (. pattern 1) `where) (list? (. pattern 2)) (= (. pattern 2 1) `or)) + (and (list? pattern) (sym? (. pattern 1) :where) (list? (. pattern 2)) (sym? (. pattern 2 1) :or)) (do - (assert-compile top-level? "can't nest (where) pattern" pattern) + (assert-compile ?top "can't nest (where) pattern" pattern) (case-or vals (. pattern 2) [(unpack pattern 3)] unifications case-pattern (with opts :in-where?))) ;; where clause - (and (list? pattern) (= (. pattern 1) `where)) + (and (list? pattern) (sym? (. pattern 1) :where)) (do - (assert-compile top-level? "can't nest (where) pattern" pattern) + (assert-compile ?top "can't nest (where) pattern" pattern) (case-guard vals (. pattern 2) [(unpack pattern 3)] unifications case-pattern (with opts :in-where?))) ;; or clause (not allowed on its own) - (and (list? pattern) (= (. pattern 1) `or)) + (and (list? pattern) (sym? (. pattern 1) :or)) (do - (assert-compile top-level? "can't nest (or) pattern" pattern) + (assert-compile ?top "can't nest (or) pattern" pattern) ;; This assertion can be removed to make patterns more permissive (assert-compile false "(or) must be used in (where) patterns" pattern) (case-or vals pattern [] unifications case-pattern opts)) ;; guard clause - (and (list? pattern) (= (. pattern 2) `?)) + (and (list? pattern) (sym? (. pattern 2) :?)) (do (assert-compile opts.legacy-guard-allowed? "legacy guard clause not supported in case" pattern) (case-guard vals (. pattern 1) [(unpack pattern 3)] unifications case-pattern opts)) @@ -6291,7 +6751,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) (case-values vals pattern unifications case-pattern opts)) ;; table patterns (= (type pattern) :table) - (case-table val pattern unifications case-pattern opts) + (case-table val pattern unifications case-pattern opts ?top) ;; literal value (values `(= ,val ,pattern) [])))) @@ -6309,7 +6769,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) ;; otherwise, keep growing the current `if` AST. out)) - (fn case-condition [vals clauses match?] + (fn case-condition [vals clauses match? top-table?] "Construct the actual `if` AST for the given match values and clauses." ;; root is the original `if` AST. ;; out is the `if` AST that is currently being grown. @@ -6322,22 +6782,21 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) {:multival? true :infer-unification? match? :legacy-guard-allowed? match?} - true) + (if top-table? :table true)) out (add-pre-bindings out pre-bindings)] ;; grow the `if` AST by one extra condition (table.insert out condition) - (table.insert out `(let ,bindings - ,body)) + (table.insert out `(let ,bindings ,body)) out)) root)) (fn count-case-multival [pattern] "Identify the amount of multival values that a pattern requires." - (if (and (list? pattern) (= (. pattern 2) `?)) + (if (and (list? pattern) (sym? (. pattern 2) :?)) (count-case-multival (. pattern 1)) - (and (list? pattern) (= (. pattern 1) `where)) + (and (list? pattern) (sym? (. pattern 1) :where)) (count-case-multival (. pattern 2)) - (and (list? pattern) (= (. pattern 1) `or)) + (and (list? pattern) (sym? (. pattern 1) :or)) (accumulate [longest 0 _ child-pattern (ipairs pattern)] (math.max longest (count-case-multival child-pattern))) @@ -6345,29 +6804,43 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) (length pattern) 1)) - (fn case-val-syms [clauses] - "What is the length of the largest multi-valued clause? return a list of that - many gensyms." + (fn case-count-syms [clauses] + "Find the length of the largest multi-valued clause" (let [patterns (fcollect [i 1 (length clauses) 2] - (. clauses i)) - sym-count (accumulate [longest 0 - _ pattern (ipairs patterns)] - (math.max longest (count-case-multival pattern)))] - (fcollect [i 1 sym-count &into (list)] - (gensym)))) + (. clauses i))] + (accumulate [longest 0 + _ pattern (ipairs patterns)] + (math.max longest (count-case-multival pattern))))) + + (fn maybe-optimize-table [val clauses] + (if (faccumulate [all (sequence? val) i 1 (length clauses) 2 &until (not all)] + (and (sequence? (. clauses i)) + (accumulate [all2 (next (. clauses i)) + _ d (ipairs (. clauses i)) &until (not all2)] + (and all2 (or (not (sym? d)) (not (: (tostring d) :find "^&"))))))) + (values `(values ,(unpack val)) + (fcollect [i 1 (length clauses)] + (if (= 1 (% i 2)) + (list (unpack (. clauses i))) + (. clauses i)))) + (values val clauses))) - (fn case-impl [match? val ...] + (fn case-impl [match? init-val ...] "The shared implementation of case and match." - (assert (not= val nil) "missing subject") + (assert (not= init-val nil) "missing subject") (assert (= 0 (math.fmod (select :# ...) 2)) "expected even number of pattern/body pairs") (assert (not= 0 (select :# ...)) "expected at least one pattern/body pair") - (let [clauses [...] - vals (case-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] (case-condition vals clauses match?)))) + (let [(val clauses) (maybe-optimize-table init-val [...]) + vals-count (case-count-syms clauses) + skips-multiple-eval-protection? (and (= vals-count 1) (double-eval-safe? val))] + (if skips-multiple-eval-protection? + (case-condition (list val) clauses match? (table? init-val)) + ;; protect against multiple evaluation of the value, bind against as + ;; many values as we ever match against in the clauses. + (let [vals (fcollect [_ 1 vals-count &into (list)] (gensym))] + (list `let [vals val] (case-condition vals clauses match? (table? init-val))))))) (fn case* [val ...] "Perform pattern matching on val. See reference for details. @@ -6377,10 +6850,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) (case data-expression pattern body (where pattern guards*) body - (or pattern patterns*) body - (where (or pattern patterns*) guards*) body - ;; legacy: - (pattern ? guards*) body)" + (where (or pattern patterns*) guards*) body)" (case-impl false val ...)) (fn match* [val ...] @@ -6392,10 +6862,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) (match data-expression pattern body (where pattern guards*) body - (or pattern patterns*) body - (where (or pattern patterns*) guards*) body - ;; legacy: - (pattern ? guards*) body)" + (where (or pattern patterns*) guards*) body)" (case-impl true val ...)) (fn case-try-step [how expr else pattern body ...] @@ -6413,7 +6880,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) (fn case-try-impl [how expr pattern body ...] (let [clauses [pattern body ...] last (. clauses (length clauses)) - catch (if (= `catch (and (= :table (type last)) (. last 1))) + catch (if (sym? (and (= :table (type last)) (. last 1)) :catch) (let [[_ & e] (table.remove clauses)] e) ; remove `catch sym [`_# `...])] (assert (= 0 (math.fmod (length clauses) 2)) @@ -6452,7 +6919,7 @@ package.preload["fennel"] = package.preload["fennel"] or function(...) :case-try case-try* :match match* :match-try match-try*} - ]===], {env = env, scope = compiler.scopes.compiler, allowedGlobals = false, useMetadata = true, filename = "src/fennel/match.fnl", moduleName = module_name}) + ]===], {allowedGlobals = false, env = env, filename = "src/fennel/match.fnl", moduleName = module_name, scope = compiler.scopes.compiler, useMetadata = true}) for k, v in pairs(match_macros) do compiler.scopes.global.macros[k] = v end @@ -6462,24 +6929,23 @@ 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 (-c) : 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 --add-macro-path PATH : Add PATH to fennel.macro-path for macro 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 --skip-include M1[,M2] : Omit certain modules from output when included\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 --raw-errors : Disable friendly compile error reporting\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\nGlobals are not checked when doing AOT (ahead-of-time) compilation unless\nthe --globals-only or --globals flag is provided. Use --globals \"*\" to disable\nstrict globals checking in other contexts.\n\nMetadata is typically considered a development feature and is not recommended\nfor production. It is used for docstrings and enabled by default in the REPL.\n\nWhen not given a command, runs the file given as the first argument.\nWhen given neither command nor file, launches a repl.\n\nUse the NO_COLOR environment variable to disable escape codes in error messages.\n\nIf ~/.fennelrc exists, it will be loaded before launching a repl." -local options = {plugins = {}} +local help = "Usage: 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 (-c) : Command to AOT compile files, writing Lua to stdout\n --eval SOURCE (-e) : Command to evaluate source code and print result\n\n --correlate : Make Lua output line numbers try to match Fennel's\n --load FILE (-l) : Load the specified FILE before executing command\n --no-compiler-sandbox : Don't limit compiler environment to minimal sandbox\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 --add-package-path PATH : Add PATH to package.path for finding Lua modules\n --add-package-cpath PATH : Add PATH to package.cpath for finding Lua modules\n --add-fennel-path PATH : Add PATH to fennel.path for finding Fennel modules\n --add-macro-path PATH : Add PATH to fennel.macro-path for macro 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 --assert-as-repl : Replace assert calls with assert-repl\n --require-as-include : Inline required modules in the output\n --skip-include M1[,M2] : Omit certain modules from output when included\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 --lua LUA_EXE : Run in a child process with LUA_EXE\n --plugin FILE : Activate the compiler plugin in FILE\n --raw-errors : Disable friendly compile error reporting\n --no-searcher : Skip installing package.searchers entry\n --no-fennelrc : Skip loading ~/.fennelrc when launching REPL\n --keywords K1[,K2...] : Treat these symbols as reserved Lua keywords\n\n --help (-h) : Display this text\n --version (-v) : Show version\n\nGlobals are not checked when doing AOT (ahead-of-time) compilation unless\nthe --globals-only or --globals flag is provided. Use --globals \"*\" to disable\nstrict globals checking in other contexts.\n\nMetadata is typically considered a development feature and is not recommended\nfor production. It is used for docstrings and enabled by default in the REPL.\n\nWhen not given a command, runs the file given as the first argument.\nWhen given neither command nor file, launches a REPL.\n\nUse the NO_COLOR environment variable to disable escape codes in error messages.\n\nIf ~/.fennelrc exists, it will be loaded before launching a REPL." +local options = {keywords = {}, plugins = {}} local function pack(...) - local _759_ = {...} - _759_["n"] = select("#", ...) - return _759_ + local _848_0 = {...} + _848_0["n"] = select("#", ...) + return _848_0 end local function dosafely(f, ...) local args = {...} - local result - local function _760_() + local result = nil + local function _849_() return f(unpack(args)) end - result = pack(xpcall(_760_, fennel.traceback)) + result = pack(xpcall(_849_, fennel.traceback)) if not result[1] then do end (io.stderr):write((result[2] .. "\n")) os.exit(1) - else end return unpack(result, 2, result.n) end @@ -6489,17 +6955,16 @@ local function allow_globals(names, actual_globals) return nil else do - local tbl_16_auto = {} - local i_17_auto = #tbl_16_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ for g in names:gmatch("([^,]+),?") do - local val_18_auto = g - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + local val_19_ = g + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - options.allowedGlobals = tbl_16_auto + options.allowedGlobals = tbl_17_ end for global_name in pairs(actual_globals) do table.insert(options.allowedGlobals, global_name) @@ -6519,119 +6984,134 @@ local function handle_lua(i) for i0 = 1, #arg do table.insert(cmd, string.format("%q", arg[i0])) end - local ok = os.execute(table.concat(cmd, " ")) - local _764_ - if ok then - _764_ = 0 + if (nil == arg[-1]) then + do end (io.stderr):write("WARNING: --lua argument only works from script, not binary.\n") + end + local _854_0, _855_0 = os.execute(table.concat(cmd, " ")) + if (((_854_0 == true) and (_855_0 == "exit")) or (_854_0 == 0)) then + return os.exit(0, true) else - _764_ = 1 + local _ = _854_0 + return os.exit(1, true) end - return os.exit(_764_, true) end -assert(arg, "Using the launcher from non-CLI context; use fennel.lua instead.") for i = #arg, 1, -1 do - local _766_ = arg[i] - if (_766_ == "--lua") then + local _857_0 = arg[i] + if (_857_0 == "--lua") then handle_lua(i) + end +end +local function load_plugin(filename) + if filename:find("%.lua$") then + return dofile(filename) else + local opts = {["compiler-env"] = _G, env = "_COMPILER", useMetadata = true} + return fennel.dofile(filename, opts) end end do - local commands = {["--repl"] = true, ["--compile"] = true, ["-c"] = true, ["--compile-binary"] = true, ["--eval"] = true, ["-e"] = true, ["-v"] = true, ["--version"] = true, ["--help"] = true, ["-h"] = true, ["-"] = true} + local commands = {["-"] = true, ["--compile"] = true, ["--compile-binary"] = true, ["--eval"] = true, ["--help"] = true, ["--repl"] = true, ["--version"] = true, ["-c"] = true, ["-e"] = true, ["-h"] = true, ["-v"] = true} local i = 1 while (arg[i] and not options["ignore-options"]) do - local _768_ = arg[i] - if (_768_ == "--no-searcher") then + local _860_0 = arg[i] + if (_860_0 == "--no-searcher") then options["no-searcher"] = true table.remove(arg, i) - elseif (_768_ == "--indent") then + elseif (_860_0 == "--indent") then options.indent = table.remove(arg, (i + 1)) if (options.indent == "false") then options.indent = false - else end table.remove(arg, i) - elseif (_768_ == "--add-package-path") then + elseif (_860_0 == "--add-package-path") then local entry = table.remove(arg, (i + 1)) package.path = (entry .. ";" .. package.path) table.remove(arg, i) - elseif (_768_ == "--add-fennel-path") then + elseif (_860_0 == "--add-package-cpath") then + local entry = table.remove(arg, (i + 1)) + package.cpath = (entry .. ";" .. package.cpath) + table.remove(arg, i) + elseif (_860_0 == "--add-fennel-path") then local entry = table.remove(arg, (i + 1)) fennel.path = (entry .. ";" .. fennel.path) table.remove(arg, i) - elseif (_768_ == "--add-macro-path") then + elseif (_860_0 == "--add-macro-path") then local entry = table.remove(arg, (i + 1)) fennel["macro-path"] = (entry .. ";" .. fennel["macro-path"]) table.remove(arg, i) - elseif (_768_ == "--load") then + elseif (_860_0 == "--load") then handle_load(i) - elseif (_768_ == "-l") then + elseif (_860_0 == "-l") then handle_load(i) - elseif (_768_ == "--no-fennelrc") then + elseif (_860_0 == "--no-fennelrc") then options.fennelrc = false table.remove(arg, i) - elseif (_768_ == "--correlate") then + elseif (_860_0 == "--correlate") then options.correlate = true table.remove(arg, i) - elseif (_768_ == "--check-unused-locals") then + elseif (_860_0 == "--check-unused-locals") then options.checkUnusedLocals = true table.remove(arg, i) - elseif (_768_ == "--globals") then + elseif (_860_0 == "--globals") then allow_globals(table.remove(arg, (i + 1)), _G) table.remove(arg, i) - elseif (_768_ == "--globals-only") then + elseif (_860_0 == "--globals-only") then allow_globals(table.remove(arg, (i + 1)), {}) table.remove(arg, i) - elseif (_768_ == "--require-as-include") then + elseif (_860_0 == "--require-as-include") then options.requireAsInclude = true table.remove(arg, i) - elseif (_768_ == "--skip-include") then + elseif (_860_0 == "--assert-as-repl") then + options.assertAsRepl = true + table.remove(arg, i) + elseif (_860_0 == "--skip-include") then local skip_names = table.remove(arg, (i + 1)) - local skip + local skip = nil do - local tbl_16_auto = {} - local i_17_auto = #tbl_16_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ for m in skip_names:gmatch("([^,]+)") do - local val_18_auto = m - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + local val_19_ = m + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - skip = tbl_16_auto + skip = tbl_17_ end options.skipInclude = skip table.remove(arg, i) - elseif (_768_ == "--use-bit-lib") then + elseif (_860_0 == "--use-bit-lib") then options.useBitLib = true table.remove(arg, i) - elseif (_768_ == "--metadata") then + elseif (_860_0 == "--metadata") then options.useMetadata = true table.remove(arg, i) - elseif (_768_ == "--no-metadata") then + elseif (_860_0 == "--no-metadata") then options.useMetadata = false table.remove(arg, i) - elseif (_768_ == "--no-compiler-sandbox") then + elseif (_860_0 == "--no-compiler-sandbox") then options["compiler-env"] = _G table.remove(arg, i) - elseif (_768_ == "--raw-errors") then + elseif (_860_0 == "--raw-errors") then options.unfriendly = true table.remove(arg, i) - elseif (_768_ == "--plugin") then - local opts = {env = "_COMPILER", useMetadata = true, ["compiler-env"] = _G} - local plugin = fennel.dofile(table.remove(arg, (i + 1)), opts) + elseif (_860_0 == "--plugin") then + local plugin = load_plugin(table.remove(arg, (i + 1))) table.insert(options.plugins, 1, plugin) table.remove(arg, i) - elseif true then - local _ = _768_ + elseif (_860_0 == "--keywords") then + for keyword in string.gmatch(table.remove(arg, (i + 1)), "[^,]+") do + options.keywords[keyword] = true + end + table.remove(arg, i) + else + local _ = _860_0 if not commands[arg[i]] then options["ignore-options"] = true i = (i + 1) - else end i = (i + 1) - else end end end @@ -6641,7 +7121,6 @@ if not options["no-searcher"] then searcher_opts[k] = v end table.insert((package.loaders or package.searchers), fennel["make-searcher"](searcher_opts)) -else end local function load_initfile() local home = (os.getenv("HOME") or "/") @@ -6649,7 +7128,7 @@ local function load_initfile() local xdg_initfile = (xdg_config_home .. "/fennel/fennelrc") local home_initfile = (home .. "/.fennelrc") local init = io.open(xdg_initfile, "rb") - local init_filename + local init_filename = nil if init then init_filename = xdg_initfile else @@ -6659,120 +7138,112 @@ local function load_initfile() if init0 then init0:close() return dosafely(fennel.dofile, init_filename, options, options, fennel) - else - return nil end end local function repl() local readline_3f = (("dumb" ~= os.getenv("TERM")) and pcall(require, "readline")) + local welcome = {("Welcome to " .. fennel["runtime-version"]() .. "!"), "Use ,help to see available commands."} searcher_opts.useMetadata = (false ~= options.useMetadata) if (false ~= options.fennelrc) then options["fennelrc"] = load_initfile - else end - print(("Welcome to " .. fennel["runtime-version"]() .. "!")) - print("Use ,help to see available commands.") if (not readline_3f and ("dumb" ~= os.getenv("TERM"))) then - print("Try installing readline via luarocks for a better repl experience.") - else + table.insert(welcome, ("Try installing readline via luarocks for a " .. "better repl experience.")) end + options.message = table.concat(welcome, "\n") return fennel.repl(options) end local function eval(form) - local _778_ + local _870_ if (form == "-") then - _778_ = (io.stdin):read("*a") + _870_ = (io.stdin):read("*a") else - _778_ = form + _870_ = form end - return print(dosafely(fennel.eval, _778_, options)) + return print(dosafely(fennel.eval, _870_, options)) end local function compile(files) for _, filename in ipairs(files) do options.filename = filename - local f + local f = nil if (filename == "-") then f = io.stdin else f = assert(io.open(filename, "rb")) end do - local _781_, _782_ = nil, nil - local function _783_() + local _873_0, _874_0 = nil, nil + local function _875_() return fennel["compile-string"](f:read("*a"), options) end - _781_, _782_ = xpcall(_783_, fennel.traceback) - if ((_781_ == true) and (nil ~= _782_)) then - local val = _782_ + _873_0, _874_0 = xpcall(_875_, fennel.traceback) + if ((_873_0 == true) and (nil ~= _874_0)) then + local val = _874_0 print(val) - elseif (true and (nil ~= _782_)) then - local _0 = _781_ - local msg = _782_ + elseif (true and (nil ~= _874_0)) then + local _0 = _873_0 + local msg = _874_0 do end (io.stderr):write((msg .. "\n")) os.exit(1) - else end end f:close() end return nil end -local _785_ = arg -local function _786_(...) +local _877_0 = arg +local function _878_(...) return (0 == #arg) end -if ((_G.type(_785_) == "table") and _786_(...)) then +if ((_G.type(_877_0) == "table") and _878_(...)) then return repl() -elseif ((_G.type(_785_) == "table") and ((_785_)[1] == "--repl")) then +elseif ((_G.type(_877_0) == "table") and (_877_0[1] == "--repl")) then return repl() -elseif ((_G.type(_785_) == "table") and ((_785_)[1] == "--compile")) then - local files = {select(2, (table.unpack or _G.unpack)(_785_))} +elseif ((_G.type(_877_0) == "table") and (_877_0[1] == "--compile")) then + local files = {select(2, (table.unpack or _G.unpack)(_877_0))} return compile(files) -elseif ((_G.type(_785_) == "table") and ((_785_)[1] == "-c")) then - local files = {select(2, (table.unpack or _G.unpack)(_785_))} +elseif ((_G.type(_877_0) == "table") and (_877_0[1] == "-c")) then + local files = {select(2, (table.unpack or _G.unpack)(_877_0))} return compile(files) -elseif ((_G.type(_785_) == "table") and ((_785_)[1] == "--compile-binary") and (nil ~= (_785_)[2]) and (nil ~= (_785_)[3]) and (nil ~= (_785_)[4]) and (nil ~= (_785_)[5])) then - local filename = (_785_)[2] - local out = (_785_)[3] - local static_lua = (_785_)[4] - local lua_include_dir = (_785_)[5] - local args = {select(6, (table.unpack or _G.unpack)(_785_))} +elseif ((_G.type(_877_0) == "table") and (_877_0[1] == "--compile-binary") and (nil ~= _877_0[2]) and (nil ~= _877_0[3]) and (nil ~= _877_0[4]) and (nil ~= _877_0[5])) then + local filename = _877_0[2] + local out = _877_0[3] + local static_lua = _877_0[4] + local lua_include_dir = _877_0[5] + local args = {select(6, (table.unpack or _G.unpack)(_877_0))} local bin = require("fennel.binary") options.filename = filename options.requireAsInclude = true return bin.compile(filename, out, static_lua, lua_include_dir, options, args) -elseif ((_G.type(_785_) == "table") and ((_785_)[1] == "--compile-binary")) then +elseif ((_G.type(_877_0) == "table") and (_877_0[1] == "--compile-binary")) then local cmd = (arg[0] or "fennel") - return print(((require("fennel.binary")).help):format(cmd, cmd, cmd)) -elseif ((_G.type(_785_) == "table") and ((_785_)[1] == "--eval") and (nil ~= (_785_)[2])) then - local form = (_785_)[2] + return print((require("fennel.binary").help):format(cmd, cmd, cmd)) +elseif ((_G.type(_877_0) == "table") and (_877_0[1] == "--eval") and (nil ~= _877_0[2])) then + local form = _877_0[2] return eval(form) -elseif ((_G.type(_785_) == "table") and ((_785_)[1] == "-e") and (nil ~= (_785_)[2])) then - local form = (_785_)[2] +elseif ((_G.type(_877_0) == "table") and (_877_0[1] == "-e") and (nil ~= _877_0[2])) then + local form = _877_0[2] return eval(form) else - local function _814_(...) - local a = (_785_)[1] + local function _908_(...) + local a = _877_0[1] return ((a == "-v") or (a == "--version")) end - if (((_G.type(_785_) == "table") and (nil ~= (_785_)[1])) and _814_(...)) then - local a = (_785_)[1] + if (((_G.type(_877_0) == "table") and (nil ~= _877_0[1])) and _908_(...)) then + local a = _877_0[1] return print(fennel["runtime-version"]()) - elseif ((_G.type(_785_) == "table") and ((_785_)[1] == "--help")) then + elseif ((_G.type(_877_0) == "table") and (_877_0[1] == "--help")) then return print(help) - elseif ((_G.type(_785_) == "table") and ((_785_)[1] == "-h")) then + elseif ((_G.type(_877_0) == "table") and (_877_0[1] == "-h")) then return print(help) - elseif ((_G.type(_785_) == "table") and ((_785_)[1] == "-")) then - local args = {select(2, (table.unpack or _G.unpack)(_785_))} + elseif ((_G.type(_877_0) == "table") and (_877_0[1] == "-")) then return dosafely(fennel.eval, (io.stdin):read("*a")) - elseif ((_G.type(_785_) == "table") and (nil ~= (_785_)[1])) then - local filename = (_785_)[1] - local args = {select(2, (table.unpack or _G.unpack)(_785_))} + elseif ((_G.type(_877_0) == "table") and (nil ~= _877_0[1])) then + local filename = _877_0[1] + local args = {select(2, (table.unpack or _G.unpack)(_877_0))} arg[-2] = arg[-1] arg[-1] = arg[0] arg[0] = table.remove(arg, 1) return dosafely(fennel.dofile, filename, options, unpack(args)) - else - return nil end end diff --git a/src/lib/fennel.lua b/src/lib/fennel.lua index 1267202..99ec748 100644 --- a/src/lib/fennel.lua +++ b/src/lib/fennel.lua @@ -1,19 +1,21 @@ +-- SPDX-License-Identifier: MIT +-- SPDX-FileCopyrightText: Calvin Rose and contributors package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) local utils = require("fennel.utils") local parser = require("fennel.parser") local compiler = require("fennel.compiler") local specials = require("fennel.specials") local view = require("fennel.view") - local unpack = (table.unpack or _G.unpack) - local function default_read_chunk(parser_state) - local function _631_() - if (0 < parser_state["stack-size"]) then - return ".." - else - return ">> " - end + local depth = 0 + local function prompt_for(top_3f) + if top_3f then + return (string.rep(">", (depth + 1)) .. " ") + else + return (string.rep(".", (depth + 1)) .. " ") end - io.write(_631_()) + end + local function default_read_chunk(parser_state) + io.write(prompt_for((0 == parser_state["stack-size"]))) io.flush() local input = io.read() return (input and (input .. "\n")) @@ -22,85 +24,78 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) io.write(table.concat(xs, "\9")) return io.write("\n") end - local function default_on_error(errtype, err, lua_source) - local function _633_() - local _632_ = errtype - if (_632_ == "Lua Compile") then - return ("Bad code generated - likely a bug with the compiler:\n" .. "--- Generated Lua Start ---\n" .. lua_source .. "--- Generated Lua End ---\n") - elseif (_632_ == "Runtime") then + local function default_on_error(errtype, err) + local function _702_() + local _701_0 = errtype + if (_701_0 == "Runtime") then return (compiler.traceback(tostring(err), 4) .. "\n") - elseif true then - local _ = _632_ - return ("%s error: %s\n"):format(errtype, tostring(err)) else - return nil + local _ = _701_0 + return ("%s error: %s\n"):format(errtype, tostring(err)) end end - return io.write(_633_()) + return io.write(_702_()) end local function splice_save_locals(env, lua_source, scope) - local saves + local saves = nil do - local tbl_16_auto = {} - local i_17_auto = #tbl_16_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ for name in pairs(env.___replLocals___) do - local val_18_auto = ("local %s = ___replLocals___['%s']"):format(name, name) - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + local val_19_ = ("local %s = ___replLocals___[%q]"):format((scope.manglings[name] or name), name) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - saves = tbl_16_auto + saves = tbl_17_ end - local binds + local binds = nil do - local tbl_16_auto = {} - local i_17_auto = #tbl_16_auto - for _, name in pairs(scope.manglings) do - local val_18_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for raw, name in pairs(scope.manglings) do + local val_19_ = nil if not scope.gensyms[name] then - val_18_auto = ("___replLocals___['%s'] = %s"):format(name, name) + val_19_ = ("___replLocals___[%q] = %s"):format(raw, name) else - val_18_auto = nil + val_19_ = nil end - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - binds = tbl_16_auto + binds = tbl_17_ end - local gap + local gap = nil if lua_source:find("\n") then gap = "\n" else gap = " " end - local function _639_() + local function _708_() if next(saves) then return (table.concat(saves, " ") .. gap) else return "" end end - local function _642_() - local _640_, _641_ = lua_source:match("^(.*)[\n ](return .*)$") - if ((nil ~= _640_) and (nil ~= _641_)) then - local body = _640_ - local _return = _641_ + local function _711_() + local _709_0, _710_0 = lua_source:match("^(.*)[\n ](return .*)$") + if ((nil ~= _709_0) and (nil ~= _710_0)) then + local body = _709_0 + local _return = _710_0 return (body .. gap .. table.concat(binds, " ") .. gap .. _return) - elseif true then - local _ = _640_ - return lua_source else - return nil + local _ = _709_0 + return lua_source end end - return (_639_() .. _642_()) + return (_708_() .. _711_()) end - local function completer(env, scope, text) + local commands = {} + local function completer(env, scope, text, _3ffulltext, _from, _to) local max_items = 2000 local seen = {} local matches = {} @@ -108,20 +103,20 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) local stop_looking_3f = false local function add_partials(input, tbl, prefix) local scope_first_3f = ((tbl == env) or (tbl == env.___replLocals___)) - local tbl_16_auto = matches - local i_17_auto = #tbl_16_auto - local function _644_() + local tbl_17_ = matches + local i_18_ = #tbl_17_ + local function _713_() if scope_first_3f then return scope.manglings else return tbl end end - for k, is_mangled in utils.allpairs(_644_()) do + for k, is_mangled in utils.allpairs(_713_()) do if (max_items <= #matches) then break end - local val_18_auto + local val_19_ = nil do - local lookup_k + local lookup_k = nil if scope_first_3f then lookup_k = is_mangled else @@ -129,21 +124,20 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) end if ((type(k) == "string") and (input == k:sub(0, #input)) and not seen[k] and ((":" ~= prefix:sub(-1)) or ("function" == type(tbl[lookup_k])))) then seen[k] = true - val_18_auto = (prefix .. k) + val_19_ = (prefix .. k) else - val_18_auto = nil + val_19_ = nil end end - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - return tbl_16_auto + return tbl_17_ end local function descend(input, tbl, prefix, add_matches, method_3f) - local splitter + local splitter = nil if method_3f then splitter = "^([^:]+):(.*)" else @@ -158,12 +152,10 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) else return add_matches(tail, tbl[raw_head], (prefix .. head)) end - else - return nil end end local function add_matches(input, tbl, prefix) - local prefix0 + local prefix0 = nil if prefix then prefix0 = (prefix .. ".") else @@ -177,102 +169,114 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) return descend(input, tbl, prefix0, add_matches, false) end end - for _, source in ipairs({scope.specials, scope.macros, (env.___replLocals___ or {}), env, env._G}) do - if stop_looking_3f then break end - add_matches(input_fragment, source) + do + local _722_0 = tostring((_3ffulltext or text)):match("^%s*,([^%s()[%]]*)$") + if (nil ~= _722_0) then + local cmd_fragment = _722_0 + add_partials(cmd_fragment, commands, ",") + else + local _ = _722_0 + for _0, source in ipairs({scope.specials, scope.macros, (env.___replLocals___ or {}), env, env._G}) do + if stop_looking_3f then break end + add_matches(input_fragment, source) + end + end end return matches end - local commands = {} local function command_3f(input) return input:match("^%s*,") end local function command_docs() - local _653_ + local _724_ do - local tbl_16_auto = {} - local i_17_auto = #tbl_16_auto - for name, f in pairs(commands) do - local val_18_auto = (" ,%s - %s"):format(name, ((compiler.metadata):get(f, "fnl/docstring") or "undocumented")) - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for name, f in utils.stablepairs(commands) do + local val_19_ = (" ,%s - %s"):format(name, ((compiler.metadata):get(f, "fnl/docstring") or "undocumented")) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - _653_ = tbl_16_auto + _724_ = tbl_17_ end - return table.concat(_653_, "\n") + return table.concat(_724_, "\n") end commands.help = function(_, _0, on_values) - return on_values({("Welcome to Fennel.\nThis is the REPL where you can enter code to be evaluated.\nYou can also run these repl commands:\n\n" .. command_docs() .. "\n ,exit - Leave the repl.\n\nUse ,doc something to see descriptions for individual macros and special forms.\n\nFor more information about the language, see https://fennel-lang.org/reference")}) + return on_values({("Welcome to Fennel.\nThis is the REPL where you can enter code to be evaluated.\nYou can also run these repl commands:\n\n" .. command_docs() .. "\n ,return FORM - Evaluate FORM and return its value to the REPL's caller.\n ,exit - Leave the repl.\n\nUse ,doc something to see descriptions for individual macros and special forms.\nValues from previous inputs are kept in *1, *2, and *3.\n\nFor more information about the language, see https://fennel-lang.org/reference")}) end do end (compiler.metadata):set(commands.help, "fnl/docstring", "Show this message.") local function reload(module_name, env, on_values, on_error) - local _655_, _656_ = pcall(specials["load-code"]("return require(...)", env), module_name) - if ((_655_ == true) and (nil ~= _656_)) then - local old = _656_ - local _ + local _726_0, _727_0 = pcall(specials["load-code"]("return require(...)", env), module_name) + if ((_726_0 == true) and (nil ~= _727_0)) then + local old = _727_0 + local _ = nil package.loaded[module_name] = nil _ = nil - local ok, new = pcall(require, module_name) - local new0 - if not ok then - on_values({new}) - new0 = old - else - new0 = new + local new = nil + do + local _728_0, _729_0 = pcall(require, module_name) + if ((_728_0 == true) and (nil ~= _729_0)) then + local new0 = _729_0 + new = new0 + elseif (true and (nil ~= _729_0)) then + local _0 = _728_0 + local msg = _729_0 + on_error("Repl", msg) + new = old + else + new = nil + end end specials["macro-loaded"][module_name] = nil - if ((type(old) == "table") and (type(new0) == "table")) then - for k, v in pairs(new0) do + if ((type(old) == "table") and (type(new) == "table")) then + for k, v in pairs(new) do old[k] = v end for k in pairs(old) do - if (nil == (new0)[k]) then + if (nil == new[k]) then old[k] = nil - else end end package.loaded[module_name] = old - else end return on_values({"ok"}) - elseif ((_655_ == false) and (nil ~= _656_)) then - local msg = _656_ + elseif ((_726_0 == false) and (nil ~= _727_0)) then + local msg = _727_0 if msg:match("loop or previous error loading module") then package.loaded[module_name] = nil return reload(module_name, env, on_values, on_error) - elseif (specials["macro-loaded"])[module_name] then + elseif specials["macro-loaded"][module_name] then specials["macro-loaded"][module_name] = nil return nil else - local function _661_() - local _660_ = msg:gsub("\n.*", "") - return _660_ + local function _734_() + local _733_0 = msg:gsub("\n.*", "") + return _733_0 end - return on_error("Runtime", _661_()) + return on_error("Runtime", _734_()) end - else - return nil end end local function run_command(read, on_error, f) - local _664_, _665_, _666_ = pcall(read) - if ((_664_ == true) and (_665_ == true) and (nil ~= _666_)) then - local val = _666_ - return f(val) - elseif (_664_ == false) then + local _737_0, _738_0, _739_0 = pcall(read) + if ((_737_0 == true) and (_738_0 == true) and (nil ~= _739_0)) then + local val = _739_0 + local _740_0, _741_0 = pcall(f, val) + if ((_740_0 == false) and (nil ~= _741_0)) then + local msg = _741_0 + return on_error("Runtime", msg) + end + elseif (_737_0 == false) then return on_error("Parse", "Couldn't parse input.") - else - return nil end end commands.reload = function(env, read, on_values, on_error) - local function _668_(_241) + local function _744_(_241) return reload(tostring(_241), env, on_values, on_error) end - return run_command(read, on_error, _668_) + return run_command(read, on_error, _744_) end do end (compiler.metadata):set(commands.reload, "fnl/docstring", "Reload the specified module.") commands.reset = function(env, _, on_values) @@ -281,281 +285,267 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) end do end (compiler.metadata):set(commands.reset, "fnl/docstring", "Erase all repl-local scope.") commands.complete = function(env, read, on_values, on_error, scope, chars) - local function _669_() - return on_values(completer(env, scope, string.char(unpack(chars)):gsub(",complete +", ""):sub(1, -2))) + local function _745_() + return on_values(completer(env, scope, table.concat(chars):gsub("^%s*,complete%s+", ""):sub(1, -2))) end - return run_command(read, on_error, _669_) + return run_command(read, on_error, _745_) end do end (compiler.metadata):set(commands.complete, "fnl/docstring", "Print all possible completions for a given input symbol.") local function apropos_2a(pattern, tbl, prefix, seen, names) for name, subtbl in pairs(tbl) do if (("string" == type(name)) and (package ~= subtbl)) then - local _670_ = type(subtbl) - if (_670_ == "function") then + local _746_0 = type(subtbl) + if (_746_0 == "function") then if ((prefix .. name)):match(pattern) then table.insert(names, (prefix .. name)) - else end - elseif (_670_ == "table") then + elseif (_746_0 == "table") then if not seen[subtbl] then - local _673_ + local _748_ do - local _672_ = seen - _672_[subtbl] = true - _673_ = _672_ + seen[subtbl] = true + _748_ = seen end - apropos_2a(pattern, subtbl, (prefix .. name:gsub("%.", "/") .. "."), _673_, names) - else + apropos_2a(pattern, subtbl, (prefix .. name:gsub("%.", "/") .. "."), _748_, names) end - else end - else end end return names end local function apropos(pattern) - local names = apropos_2a(pattern, package.loaded, "", {}, {}) - local tbl_16_auto = {} - local i_17_auto = #tbl_16_auto - for _, name in ipairs(names) do - local val_18_auto = name:gsub("^_G%.", "") - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else - end - end - return tbl_16_auto + return apropos_2a(pattern:gsub("^_G%.", ""), package.loaded, "", {}, {}) end commands.apropos = function(_env, read, on_values, on_error, _scope) - local function _678_(_241) + local function _752_(_241) return on_values(apropos(tostring(_241))) end - return run_command(read, on_error, _678_) + return run_command(read, on_error, _752_) end do end (compiler.metadata):set(commands.apropos, "fnl/docstring", "Print all functions matching a pattern in all loaded modules.") local function apropos_follow_path(path) - local paths + local paths = nil do - local tbl_16_auto = {} - local i_17_auto = #tbl_16_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ for p in path:gmatch("[^%.]+") do - local val_18_auto = p - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + local val_19_ = p + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - paths = tbl_16_auto + paths = tbl_17_ end local tgt = package.loaded for _, path0 in ipairs(paths) do if (nil == tgt) then break end - local _681_ + local _755_ do - local _680_ = path0:gsub("%/", ".") - _681_ = _680_ + local _754_0 = path0:gsub("%/", ".") + _755_ = _754_0 end - tgt = tgt[_681_] + tgt = tgt[_755_] end return tgt end local function apropos_doc(pattern) - local tbl_16_auto = {} - local i_17_auto = #tbl_16_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ for _, path in ipairs(apropos(".*")) do - local val_18_auto + local val_19_ = nil do local tgt = apropos_follow_path(path) if ("function" == type(tgt)) then - local _682_ = (compiler.metadata):get(tgt, "fnl/docstring") - if (nil ~= _682_) then - local docstr = _682_ - val_18_auto = (docstr:match(pattern) and path) + local _756_0 = (compiler.metadata):get(tgt, "fnl/docstring") + if (nil ~= _756_0) then + local docstr = _756_0 + val_19_ = (docstr:match(pattern) and path) else - val_18_auto = nil + val_19_ = nil end else - val_18_auto = nil + val_19_ = nil end end - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - return tbl_16_auto + return tbl_17_ end commands["apropos-doc"] = function(_env, read, on_values, on_error, _scope) - local function _686_(_241) + local function _760_(_241) return on_values(apropos_doc(tostring(_241))) end - return run_command(read, on_error, _686_) + return run_command(read, on_error, _760_) end do end (compiler.metadata):set(commands["apropos-doc"], "fnl/docstring", "Print all functions that match the pattern in their docs") local function apropos_show_docs(on_values, pattern) for _, path in ipairs(apropos(pattern)) do local tgt = apropos_follow_path(path) if (("function" == type(tgt)) and (compiler.metadata):get(tgt, "fnl/docstring")) then - on_values(specials.doc(tgt, path)) - on_values() - else + on_values({specials.doc(tgt, path)}) + on_values({}) end end return nil end commands["apropos-show-docs"] = function(_env, read, on_values, on_error) - local function _688_(_241) + local function _762_(_241) return apropos_show_docs(on_values, tostring(_241)) end - return run_command(read, on_error, _688_) + return run_command(read, on_error, _762_) end do end (compiler.metadata):set(commands["apropos-show-docs"], "fnl/docstring", "Print all documentations matching a pattern in function name") - local function resolve(identifier, _689_, scope) - local _arg_690_ = _689_ - local ___replLocals___ = _arg_690_["___replLocals___"] - local env = _arg_690_ - local e - local function _691_(_241, _242) - return (___replLocals___[_242] or env[_242]) - end - e = setmetatable({}, {__index = _691_}) - local _692_, _693_ = pcall(compiler["compile-string"], tostring(identifier), {scope = scope}) - if ((_692_ == true) and (nil ~= _693_)) then - local code = _693_ - return specials["load-code"](code, e)() - else - return nil + local function resolve(identifier, _763_0, scope) + local _764_ = _763_0 + local env = _764_ + local ___replLocals___ = _764_["___replLocals___"] + local e = nil + local function _765_(_241, _242) + return (___replLocals___[scope.unmanglings[_242]] or env[_242]) + end + e = setmetatable({}, {__index = _765_}) + local function _766_(...) + local _767_0, _768_0 = ... + if ((_767_0 == true) and (nil ~= _768_0)) then + local code = _768_0 + local function _769_(...) + local _770_0, _771_0 = ... + if ((_770_0 == true) and (nil ~= _771_0)) then + local val = _771_0 + return val + else + local _ = _770_0 + return nil + end + end + return _769_(pcall(specials["load-code"](code, e))) + else + local _ = _767_0 + return nil + end end + return _766_(pcall(compiler["compile-string"], tostring(identifier), {scope = scope})) end commands.find = function(env, read, on_values, on_error, scope) - local function _695_(_241) - local _696_ + local function _774_(_241) + local _775_0 = nil do - local _697_ = utils["sym?"](_241) - if (nil ~= _697_) then - local _698_ = resolve(_697_, env, scope) - if (nil ~= _698_) then - _696_ = debug.getinfo(_698_) + local _776_0 = utils["sym?"](_241) + if (nil ~= _776_0) then + local _777_0 = resolve(_776_0, env, scope) + if (nil ~= _777_0) then + _775_0 = debug.getinfo(_777_0) else - _696_ = _698_ + _775_0 = _777_0 end else - _696_ = _697_ + _775_0 = _776_0 end end - if ((_G.type(_696_) == "table") and ((_696_).what == "Lua") and (nil ~= (_696_).source) and (nil ~= (_696_).linedefined) and (nil ~= (_696_).short_src)) then - local source = (_696_).source - local line = (_696_).linedefined - local src = (_696_).short_src - local fnlsrc + if ((_G.type(_775_0) == "table") and (nil ~= _775_0.linedefined) and (nil ~= _775_0.short_src) and (nil ~= _775_0.source) and (_775_0.what == "Lua")) then + local line = _775_0.linedefined + local src = _775_0.short_src + local source = _775_0.source + local fnlsrc = nil do - local t_701_ = compiler.sourcemap - if (nil ~= t_701_) then - t_701_ = (t_701_)[source] - else + local _780_0 = compiler.sourcemap + if (nil ~= _780_0) then + _780_0 = _780_0[source] end - if (nil ~= t_701_) then - t_701_ = (t_701_)[line] - else + if (nil ~= _780_0) then + _780_0 = _780_0[line] end - if (nil ~= t_701_) then - t_701_ = (t_701_)[2] - else + if (nil ~= _780_0) then + _780_0 = _780_0[2] end - fnlsrc = t_701_ + fnlsrc = _780_0 end return on_values({string.format("%s:%s", src, (fnlsrc or line))}) - elseif (_696_ == nil) then + elseif (_775_0 == nil) then return on_error("Repl", "Unknown value") - elseif true then - local _ = _696_ - return on_error("Repl", "No source info") else - return nil + local _ = _775_0 + return on_error("Repl", "No source info") end end - return run_command(read, on_error, _695_) + return run_command(read, on_error, _774_) end do end (compiler.metadata):set(commands.find, "fnl/docstring", "Print the filename and line number for a given function") commands.doc = function(env, read, on_values, on_error, scope) - local function _706_(_241) + local function _785_(_241) local name = tostring(_241) local path = (utils["multi-sym?"](name) or {name}) local ok_3f, target = nil, nil - local function _707_() - return (utils["get-in"](scope.specials, path) or utils["get-in"](scope.macros, path) or resolve(name, env, scope)) + local function _786_() + return (scope.specials[name] or utils["get-in"](scope.macros, path) or resolve(name, env, scope)) end - ok_3f, target = pcall(_707_) + ok_3f, target = pcall(_786_) if ok_3f then return on_values({specials.doc(target, name)}) else - return on_error("Repl", "Could not resolve value for docstring lookup") + return on_error("Repl", ("Could not find " .. name .. " for docs.")) end end - return run_command(read, on_error, _706_) + return run_command(read, on_error, _785_) end do end (compiler.metadata):set(commands.doc, "fnl/docstring", "Print the docstring and arglist for a function, macro, or special form.") - commands.compile = function(env, read, on_values, on_error, scope) - local function _709_(_241) - local allowedGlobals = specials["current-global-names"](env) - local ok_3f, result = pcall(compiler.compile, _241, {env = env, scope = scope, allowedGlobals = allowedGlobals}) - if ok_3f then + commands.compile = function(_, read, on_values, on_error, _0, _1, opts) + local function _788_(_241) + local _789_0, _790_0 = pcall(compiler.compile, _241, opts) + if ((_789_0 == true) and (nil ~= _790_0)) then + local result = _790_0 return on_values({result}) - else - return on_error("Repl", ("Error compiling expression: " .. result)) + elseif (true and (nil ~= _790_0)) then + local _2 = _789_0 + local msg = _790_0 + return on_error("Repl", ("Error compiling expression: " .. msg)) end end - return run_command(read, on_error, _709_) + return run_command(read, on_error, _788_) end do end (compiler.metadata):set(commands.compile, "fnl/docstring", "compiles the expression into lua and prints the result.") local function load_plugin_commands(plugins) - for _, plugin in ipairs((plugins or {})) do - for name, f in pairs(plugin) do - local _711_ = name:match("^repl%-command%-(.*)") - if (nil ~= _711_) then - local cmd_name = _711_ - commands[cmd_name] = (commands[cmd_name] or f) - else + for i = #(plugins or {}), 1, -1 do + for name, f in pairs(plugins[i]) do + local _792_0 = name:match("^repl%-command%-(.*)") + if (nil ~= _792_0) then + local cmd_name = _792_0 + commands[cmd_name] = f end end end return nil end - local function run_command_loop(input, read, loop, env, on_values, on_error, scope, chars) + local function run_command_loop(input, read, loop, env, on_values, on_error, scope, chars, opts) local command_name = input:match(",([^%s/]+)") do - local _713_ = commands[command_name] - if (nil ~= _713_) then - local command = _713_ - command(env, read, on_values, on_error, scope, chars) - elseif true then - local _ = _713_ - if ("exit" ~= command_name) then + local _794_0 = commands[command_name] + if (nil ~= _794_0) then + local command = _794_0 + command(env, read, on_values, on_error, scope, chars, opts) + else + local _ = _794_0 + if ((command_name ~= "exit") and (command_name ~= "return")) then on_values({"Unknown command", command_name}) - else end - else end end if ("exit" ~= command_name) then - return loop() - else - return nil + return loop((command_name == "return")) end end local function try_readline_21(opts, ok, readline) if ok then if readline.set_readline_name then readline.set_readline_name("fennel") - else end - readline.set_options({keeplines = 1000, histfile = ""}) + readline.set_options({histfile = "", keeplines = 1000}) opts.readChunk = function(parser_state) - local prompt + local prompt = nil if (0 < parser_state["stack-size"]) then prompt = ".. " else @@ -564,8 +554,6 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) local str = readline.readline(prompt) if str then return (str .. "\n") - else - return nil end end local completer0 = nil @@ -576,15 +564,13 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) local function repl_completer(text, from, to) if completer0 then readline.set_completion_append_character("") - return completer0(text:sub(from, to)) + return completer0(text:sub(from, to), text, from, to) else return {} end end readline.set_complete_function(repl_completer) return readline - else - return nil end end local function should_use_readline_3f(opts) @@ -592,148 +578,170 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) end local function repl(_3foptions) local old_root_options = utils.root.options - local _let_722_ = utils.copy(_3foptions) - local _3ffennelrc = _let_722_["fennelrc"] - local opts = _let_722_ - local _ + local _803_ = utils.copy(_3foptions) + local opts = _803_ + local _3ffennelrc = _803_["fennelrc"] + local _ = nil opts.fennelrc = nil _ = nil local readline = (should_use_readline_3f(opts) and try_readline_21(opts, pcall(require, "readline"))) - local _0 + local _0 = nil if _3ffennelrc then _0 = _3ffennelrc() else - _0 = nil + _0 = nil end local env = specials["wrap-env"]((opts.env or rawget(_G, "_ENV") or _G)) + local callbacks = {["view-opts"] = (opts["view-opts"] or {depth = 4}), env = env, onError = (opts.onError or default_on_error), onValues = (opts.onValues or default_on_values), pp = (opts.pp or view), readChunk = (opts.readChunk or default_read_chunk)} local save_locals_3f = (opts.saveLocals ~= false) - local read_chunk = (opts.readChunk or default_read_chunk) - local on_values = (opts.onValues or default_on_values) - local on_error = (opts.onError or default_on_error) - local pp = (opts.pp or view) - local byte_stream, clear_stream = parser.granulate(read_chunk) + local byte_stream, clear_stream = nil, nil + local function _805_(_241) + return callbacks.readChunk(_241) + end + byte_stream, clear_stream = parser.granulate(_805_) local chars = {} local read, reset = nil, nil - local function _724_(parser_state) - local c = byte_stream(parser_state) - table.insert(chars, c) - return c + local function _806_(parser_state) + local b = byte_stream(parser_state) + if b then + table.insert(chars, string.char(b)) + end + return b end - read, reset = parser.parser(_724_) + read, reset = parser.parser(_806_) + depth = (depth + 1) + if opts.message then + callbacks.onValues({opts.message}) + end + env.___repl___ = callbacks opts.env, opts.scope = env, compiler["make-scope"]() opts.useMetadata = (opts.useMetadata ~= false) if (opts.allowedGlobals == nil) then opts.allowedGlobals = specials["current-global-names"](env) - else + end + if opts.init then + opts.init(opts, depth) end if opts.registerCompleter then - local function _728_() - local _726_ = env - local _727_ = opts.scope - local function _729_(...) - return completer(_726_, _727_, ...) + local function _812_() + local _811_0 = opts.scope + local function _813_(...) + return completer(env, _811_0, ...) end - return _729_ + return _813_ end - opts.registerCompleter(_728_()) - else + opts.registerCompleter(_812_()) end load_plugin_commands(opts.plugins) if save_locals_3f then local function newindex(t, k, v) - if opts.scope.unmanglings[k] then + if opts.scope.manglings[k] then return rawset(t, k, v) - else - return nil end end env.___replLocals___ = setmetatable({}, {__newindex = newindex}) - else end local function print_values(...) local vals = {...} local out = {} + local pp = callbacks.pp env._, env.__ = vals[1], vals for i = 1, select("#", ...) do - table.insert(out, pp(vals[i])) + table.insert(out, pp(vals[i], callbacks["view-opts"])) end - return on_values(out) + return callbacks.onValues(out) + end + local function save_value(...) + env.___replLocals___["*3"] = env.___replLocals___["*2"] + env.___replLocals___["*2"] = env.___replLocals___["*1"] + env.___replLocals___["*1"] = ... + return ... end - local function loop() + opts.scope.manglings["*1"], opts.scope.unmanglings._1 = "_1", "*1" + opts.scope.manglings["*2"], opts.scope.unmanglings._2 = "_2", "*2" + opts.scope.manglings["*3"], opts.scope.unmanglings._3 = "_3", "*3" + local function loop(exit_next_3f) for k in pairs(chars) do chars[k] = nil end reset() - local ok, parser_not_eof_3f, x = pcall(read) - local src_string = string.char(unpack(chars)) + local ok, parser_not_eof_3f, form = pcall(read) + local src_string = table.concat(chars) local readline_not_eof_3f = (not readline or (src_string ~= "(null)")) local not_eof_3f = (readline_not_eof_3f and parser_not_eof_3f) if not ok then - on_error("Parse", not_eof_3f) + callbacks.onError("Parse", not_eof_3f) clear_stream() return loop() elseif command_3f(src_string) then - return run_command_loop(src_string, read, loop, env, on_values, on_error, opts.scope, chars) + return run_command_loop(src_string, read, loop, env, callbacks.onValues, callbacks.onError, opts.scope, chars, opts) else if not_eof_3f then - do - local _733_, _734_ = nil, nil - local function _736_() - local _735_ = opts - _735_["source"] = src_string - return _735_ - end - _733_, _734_ = pcall(compiler.compile, x, _736_()) - if ((_733_ == false) and (nil ~= _734_)) then - local msg = _734_ - clear_stream() - on_error("Compile", msg) - elseif ((_733_ == true) and (nil ~= _734_)) then - local src = _734_ - local src0 - if save_locals_3f then - src0 = splice_save_locals(env, src, opts.scope) - else - src0 = src - end - local _738_, _739_ = pcall(specials["load-code"], src0, env) - if ((_738_ == false) and (nil ~= _739_)) then - local msg = _739_ - clear_stream() - on_error("Lua Compile", msg, src0) - elseif (true and (nil ~= _739_)) then - local _1 = _738_ - local chunk = _739_ - local function _740_() - return print_values(chunk()) - end - local function _741_() - local function _742_(...) - return on_error("Runtime", ...) + local function _817_(...) + local _818_0, _819_0 = ... + if ((_818_0 == true) and (nil ~= _819_0)) then + local src = _819_0 + local function _820_(...) + local _821_0, _822_0 = ... + if ((_821_0 == true) and (nil ~= _822_0)) then + local chunk = _822_0 + local function _823_() + return print_values(save_value(chunk())) end - return _742_ + local function _824_(...) + return callbacks.onError("Runtime", ...) + end + return xpcall(_823_, _824_) + elseif ((_821_0 == false) and (nil ~= _822_0)) then + local msg = _822_0 + clear_stream() + return callbacks.onError("Compile", msg) end - xpcall(_740_, _741_()) - else end - else + local function _827_(...) + local src0 = nil + if save_locals_3f then + src0 = splice_save_locals(env, src, opts.scope) + else + src0 = src + end + return pcall(specials["load-code"], src0, env) + end + return _820_(_827_(...)) + elseif ((_818_0 == false) and (nil ~= _819_0)) then + local msg = _819_0 + clear_stream() + return callbacks.onError("Compile", msg) end end + local function _829_() + opts["source"] = src_string + return opts + end + _817_(pcall(compiler.compile, form, _829_())) utils.root.options = old_root_options - return loop() - else - return nil + if exit_next_3f then + return env.___replLocals___["*1"] + else + return loop() + end end end end - loop() + local value = loop() + depth = (depth - 1) if readline then - return readline.save_history() - else - return nil + readline.save_history() + end + if opts.exit then + opts.exit(opts, depth) end + return value end - return repl + local function _835_(overrides, _3fopts) + return repl(utils.copy(_3fopts, utils.copy(overrides))) + end + return setmetatable({}, {__call = _835_, __index = {repl = repl}}) end package.preload["fennel.specials"] = package.preload["fennel.specials"] or function(...) local utils = require("fennel.utils") @@ -742,15 +750,18 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local compiler = require("fennel.compiler") local unpack = (table.unpack or _G.unpack) local SPECIALS = compiler.scopes.global.specials + local function str1(x) + return tostring(x[1]) + end local function wrap_env(env) - local function _424_(_, key) + local function _475_(_, key) if utils["string?"](key) then return env[compiler["global-unmangling"](key)] else return env[key] end end - local function _426_(_, key, value) + local function _477_(_, key, value) if utils["string?"](key) then env[compiler["global-unmangling"](key)] = value return nil @@ -759,82 +770,105 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return nil end end - local function _428_() - local function putenv(k, v) - local _429_ - if utils["string?"](k) then - _429_ = compiler["global-unmangling"](k) - else - _429_ = k + local function _479_() + local _480_ + do + local tbl_14_ = {} + for k, v in utils.stablepairs(env) do + local k_15_, v_16_ = nil, nil + local _481_ + if utils["string?"](k) then + _481_ = compiler["global-unmangling"](k) + else + _481_ = k + end + k_15_, v_16_ = _481_, v + if ((k_15_ ~= nil) and (v_16_ ~= nil)) then + tbl_14_[k_15_] = v_16_ + end end - return _429_, v + _480_ = tbl_14_ end - return next, utils.kvmap(env, putenv), nil + return next, _480_, nil end - return setmetatable({}, {__index = _424_, __newindex = _426_, __pairs = _428_}) + return setmetatable({}, {__index = _475_, __newindex = _477_, __pairs = _479_}) + end + local function fennel_module_name() + return (utils.root.options.moduleName or "fennel") end local function current_global_names(_3fenv) - local mt + local mt = nil do - local _431_ = getmetatable(_3fenv) - if ((_G.type(_431_) == "table") and (nil ~= (_431_).__pairs)) then - local mtpairs = (_431_).__pairs - local tbl_13_auto = {} + local _484_0 = getmetatable(_3fenv) + if ((_G.type(_484_0) == "table") and (nil ~= _484_0.__pairs)) then + local mtpairs = _484_0.__pairs + local tbl_14_ = {} for k, v in mtpairs(_3fenv) do - local k_14_auto, v_15_auto = k, v - if ((k_14_auto ~= nil) and (v_15_auto ~= nil)) then - tbl_13_auto[k_14_auto] = v_15_auto - else + local k_15_, v_16_ = k, v + if ((k_15_ ~= nil) and (v_16_ ~= nil)) then + tbl_14_[k_15_] = v_16_ end end - mt = tbl_13_auto - elseif (_431_ == nil) then + mt = tbl_14_ + elseif (_484_0 == nil) then mt = (_3fenv or _G) else - mt = nil + mt = nil + end + end + local function _487_() + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for k in utils.stablepairs(mt) do + local val_19_ = compiler["global-unmangling"](k) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end end + return tbl_17_ end - return (mt and utils.kvmap(mt, compiler["global-unmangling"])) + return (mt and _487_()) end local function load_code(code, _3fenv, _3ffilename) local env = (_3fenv or rawget(_G, "_ENV") or _G) - local _434_, _435_ = rawget(_G, "setfenv"), rawget(_G, "loadstring") - if ((nil ~= _434_) and (nil ~= _435_)) then - local setfenv = _434_ - local loadstring = _435_ + local _489_0, _490_0 = rawget(_G, "setfenv"), rawget(_G, "loadstring") + if ((nil ~= _489_0) and (nil ~= _490_0)) then + local setfenv = _489_0 + local loadstring = _490_0 local f = assert(loadstring(code, _3ffilename)) - local _436_ = f - setfenv(_436_, env) - return _436_ - elseif true then - local _ = _434_ - return assert(load(code, _3ffilename, "t", env)) + setfenv(f, env) + return f else - return nil + local _ = _489_0 + return assert(load(code, _3ffilename, "t", env)) end end + local function v__3edocstring(tgt) + return (((compiler.metadata):get(tgt, "fnl/docstring") or "#")):gsub("\n$", ""):gsub("\n", "\n ") + end local function doc_2a(tgt, name) + assert(("string" == type(name)), "name must be a string") if not tgt then return (name .. " not found") else - local docstring = (((compiler.metadata):get(tgt, "fnl/docstring") or "#")):gsub("\n$", ""):gsub("\n", "\n ") - local mt = getmetatable(tgt) - if ((type(tgt) == "function") or ((type(mt) == "table") and (type(mt.__call) == "function"))) then - local arglist = table.concat(((compiler.metadata):get(tgt, "fnl/arglist") or {"#"}), " ") - local _438_ - if (0 < #arglist) then - _438_ = " " - else - _438_ = "" + local function _493_() + local _492_0 = getmetatable(tgt) + if ((_G.type(_492_0) == "table") and true) then + local __call = _492_0.__call + return ("function" == type(__call)) end - return string.format("(%s%s%s)\n %s", name, _438_, arglist, docstring) + end + if ((type(tgt) == "function") or _493_()) then + local elts = {name, unpack(((compiler.metadata):get(tgt, "fnl/arglist") or {"#"}))} + return string.format("(%s)\n %s", table.concat(elts, " "), v__3edocstring(tgt)) else - return string.format("%s\n %s", name, docstring) + return string.format("%s\n %s", name, v__3edocstring(tgt)) end end end local function doc_special(name, arglist, docstring, body_form_3f) - compiler.metadata[SPECIALS[name]] = {["fnl/arglist"] = arglist, ["fnl/docstring"] = docstring, ["fnl/body-form?"] = body_form_3f} + compiler.metadata[SPECIALS[name]] = {["fnl/arglist"] = arglist, ["fnl/body-form?"] = body_form_3f, ["fnl/docstring"] = docstring} return nil end local function compile_do(ast, scope, parent, _3fstart) @@ -852,18 +886,14 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local chunk = (_3fchunk or {}) local len = #ast local retexprs = {returned = true} + utils.hook("pre-do", ast, sub_scope) local function compile_body(outer_target, outer_tail, outer_retexprs) - if (len < start) then - compiler.compile1(nil, sub_scope, chunk, {tail = outer_tail, target = outer_target}) - else - for i = start, len do - local subopts = {nval = (((i ~= len) and 0) or opts.nval), tail = (((i == len) and outer_tail) or nil), target = (((i == len) and outer_target) or nil)} - local _ = utils["propagate-options"](opts, subopts) - local subexprs = compiler.compile1(ast[i], sub_scope, chunk, subopts) - if (i ~= len) then - compiler["keep-side-effects"](subexprs, parent, nil, ast[i]) - else - end + for i = start, len do + local subopts = {nval = (((i ~= len) and 0) or opts.nval), tail = (((i == len) and outer_tail) or nil), target = (((i == len) and outer_target) or nil)} + local _ = utils["propagate-options"](opts, subopts) + local subexprs = compiler.compile1(ast[i], sub_scope, chunk, subopts) + if (i ~= len) then + compiler["keep-side-effects"](subexprs, parent, nil, ast[i]) end end compiler.emit(parent, chunk, ast) @@ -877,8 +907,8 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct elseif opts.nval then local syms = {} for i = 1, opts.nval do - local s = ((_3fpre_syms and (_3fpre_syms)[i]) or compiler.gensym(scope)) - do end (syms)[i] = s + local s = ((_3fpre_syms and _3fpre_syms[i]) or compiler.gensym(scope)) + syms[i] = s retexprs[i] = utils.expr(s, "sym") end local outer_target = table.concat(syms, ", ") @@ -887,7 +917,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return compile_body(outer_target, opts.tail) else local fname = compiler.gensym(scope) - local fargs + local fargs = nil if scope.vararg then fargs = "..." else @@ -898,17 +928,28 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end end doc_special("do", {"..."}, "Evaluate multiple forms; return last value.", true) + local function iter_args(ast) + local ast0, len, i = ast, #ast, 1 + local function _499_() + i = (1 + i) + while ((i == len) and utils["call-of?"](ast0[i], "values")) do + ast0 = ast0[i] + len = #ast0 + i = 2 + end + return ast0[i], (nil == ast0[(i + 1)]) + end + return _499_ + end SPECIALS.values = function(ast, scope, parent) - local len = #ast local exprs = {} - for i = 2, len do - local subexprs = compiler.compile1(ast[i], scope, parent, {nval = ((i ~= len) and 1)}) + for subast, last_3f in iter_args(ast) do + local subexprs = compiler.compile1(subast, scope, parent, {nval = (not last_3f and 1)}) table.insert(exprs, subexprs[1]) - if (i == len) then + if last_3f then for j = 2, #subexprs do table.insert(exprs, subexprs[j]) end - else end end return exprs @@ -916,9 +957,8 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct doc_special("values", {"..."}, "Return multiple values from a function. Must be in tail position.") local function __3estack(stack, tbl) for k, v in pairs(tbl) do - local _447_ = stack - table.insert(_447_, k) - table.insert(_447_, v) + table.insert(stack, k) + table.insert(stack, v) end return stack end @@ -934,10 +974,8 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct res = false elseif utils["table?"](elt) then __3estack(stack, elt) - else end end - else end return res end @@ -945,36 +983,44 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local opts = {nval = 1, tail = false} local scope = compiler["make-scope"]() local chunk = {} - local _let_450_ = compiler.compile1(v, scope, chunk, opts) - local _let_451_ = _let_450_[1] - local v0 = _let_451_[1] + local _503_ = compiler.compile1(v, scope, chunk, opts) + local _504_ = _503_[1] + local v0 = _504_[1] return v0 end local function insert_meta(meta, k, v) local view_opts = {["escape-newlines?"] = true, ["line-length"] = math.huge, ["one-line?"] = true} compiler.assert((type(k) == "string"), ("expected string keys in metadata table, got: %s"):format(view(k, view_opts))) compiler.assert(literal_3f(v), ("expected literal value in metadata table, got: %s %s"):format(view(k, view_opts), view(v, view_opts))) - local _452_ = meta - table.insert(_452_, view(k)) - local function _453_() + table.insert(meta, view(k)) + local function _505_() if ("string" == type(v)) then return view(v, view_opts) else return compile_value(v) end end - table.insert(_452_, _453_()) - return _452_ + table.insert(meta, _505_()) + return meta end local function insert_arglist(meta, arg_list) - local view_opts = {["one-line?"] = true, ["escape-newlines?"] = true, ["line-length"] = math.huge} - local _454_ = meta - table.insert(_454_, "\"fnl/arglist\"") - local function _455_(_241) - return view(view(_241, view_opts)) + local opts = {["escape-newlines?"] = true, ["line-length"] = math.huge, ["one-line?"] = true} + local view_args = nil + do + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for _, arg in ipairs(arg_list) do + local val_19_ = view(view(arg, opts)) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end + end + view_args = tbl_17_ end - table.insert(_454_, ("{" .. table.concat(utils.map(arg_list, _455_), ", ") .. "}")) - return _454_ + table.insert(meta, "\"fnl/arglist\"") + table.insert(meta, ("{" .. table.concat(view_args, ", ") .. "}")) + return meta end local function set_fn_metadata(f_metadata, parent, fn_name) if utils.root.options.useMetadata then @@ -986,36 +1032,35 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct insert_meta(meta_fields, k, v) end end - local meta_str = ("require(\"%s\").metadata"):format((utils.root.options.moduleName or "fennel")) + local meta_str = ("require(\"%s\").metadata"):format(fennel_module_name()) return compiler.emit(parent, ("pcall(function() %s:setall(%s, %s) end)"):format(meta_str, fn_name, table.concat(meta_fields, ", "))) - else - return nil end end local function get_fn_name(ast, scope, fn_name, multi) if (fn_name and (fn_name[1] ~= "nil")) then - local _458_ + local _509_ if not multi then - _458_ = compiler["declare-local"](fn_name, {}, scope, ast) + _509_ = compiler["declare-local"](fn_name, scope, ast) else - _458_ = (compiler["symbol-to-expression"](fn_name, scope))[1] + _509_ = compiler["symbol-to-expression"](fn_name, scope)[1] end - return _458_, not multi, 3 + return _509_, not multi, 3 else 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, f_metadata) + utils.hook("pre-fn", ast, f_scope) 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 _461_ + local _512_ if local_3f then - _461_ = "local function %s(%s)" + _512_ = "local function %s(%s)" else - _461_ = "%s = function(%s)" + _512_ = "%s = function(%s)" end - compiler.emit(parent, string.format(_461_, fn_name, table.concat(arg_name_list, ", ")), ast) + compiler.emit(parent, string.format(_512_, fn_name, table.concat(arg_name_list, ", ")), ast) compiler.emit(parent, f_chunk, ast) compiler.emit(parent, "end", ast) set_fn_metadata(f_metadata, parent, fn_name) @@ -1026,64 +1071,52 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local fn_name = compiler.gensym(scope) return compile_named_fn(ast, f_scope, f_chunk, parent, index, fn_name, true, arg_name_list, f_metadata) end - local function assoc_table_3f(t) - local len = #t - local nxt, t0, k = pairs(t) - local function _463_() - if (len == 0) then - return k - else - return len - end + local function maybe_metadata(ast, pred, handler, mt, index) + local index_2a = (index + 1) + local index_2a_before_ast_end_3f = (index_2a < #ast) + local expr = ast[index_2a] + if (index_2a_before_ast_end_3f and pred(expr)) then + return handler(mt, expr), index_2a + else + return mt, index end - return (nil ~= nxt(t0, _463_())) end local function get_function_metadata(ast, arg_list, index) - local f_metadata = {["fnl/arglist"] = arg_list} - local index_2a = (index + 1) - local expr = ast[index_2a] - if (utils["string?"](expr) and (index_2a < #ast)) then - local _465_ - do - local _464_ = f_metadata - _464_["fnl/docstring"] = expr - _465_ = _464_ - end - return _465_, index_2a - elseif (utils["table?"](expr) and (index_2a < #ast) and assoc_table_3f(expr)) then - local _466_ - do - local tbl_13_auto = f_metadata - for k, v in pairs(expr) do - local k_14_auto, v_15_auto = k, v - if ((k_14_auto ~= nil) and (v_15_auto ~= nil)) then - tbl_13_auto[k_14_auto] = v_15_auto - else - end + local function _515_(_241, _242) + local tbl_14_ = _241 + for k, v in pairs(_242) do + local k_15_, v_16_ = k, v + if ((k_15_ ~= nil) and (v_16_ ~= nil)) then + tbl_14_[k_15_] = v_16_ end - _466_ = tbl_13_auto end - return _466_, index_2a - else - return f_metadata, index + return tbl_14_ + end + local function _517_(_241, _242) + _241["fnl/docstring"] = _242 + return _241 end + return maybe_metadata(ast, utils["kv-table?"], _515_, maybe_metadata(ast, utils["string?"], _517_, {["fnl/arglist"] = arg_list}, index)) end - SPECIALS.fn = function(ast, scope, parent) - local f_scope + SPECIALS.fn = function(ast, scope, parent, opts) + local f_scope = nil do - local _469_ = compiler["make-scope"](scope) - do end (_469_)["vararg"] = false - f_scope = _469_ + local _518_0 = compiler["make-scope"](scope) + _518_0["vararg"] = false + f_scope = _518_0 end 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_3f, index = get_fn_name(ast, scope, fn_sym, multi) + local fn_name, local_3f, index = get_fn_name(ast, scope, fn_sym, multi, opts) 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) + if (multi and not scope.symmeta[multi[1]] and not compiler["global-allowed?"](multi[1])) then + compiler.assert(nil, ("expected local table " .. multi[1]), ast[2]) + end local function destructure_arg(arg) local raw = utils.sym(compiler.gensym(scope)) - local declared = compiler["declare-local"](raw, {}, f_scope, ast) + local declared = compiler["declare-local"](raw, f_scope, ast) compiler.destructure(arg, raw, ast, f_scope, f_chunk, {declaration = true, nomulti = true, symtype = "arg"}) return declared end @@ -1100,29 +1133,28 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct compiler.assert((arg == arg_list[#arg_list]), "expected vararg as last parameter", ast) f_scope.vararg = true return "..." - elseif (utils.sym("&") == arg) then + elseif utils["sym?"](arg, "&") then return destructure_amp(i) elseif (utils["sym?"](arg) and (tostring(arg) ~= "nil") and not utils["multi-sym?"](tostring(arg))) then - return compiler["declare-local"](arg, {}, f_scope, ast) + return compiler["declare-local"](arg, f_scope, ast) elseif utils["table?"](arg) then return destructure_arg(arg) else return compiler.assert(false, ("expected symbol for function parameter: %s"):format(tostring(arg)), ast[index]) end end - local arg_name_list + local arg_name_list = nil do - local tbl_16_auto = {} - local i_17_auto = #tbl_16_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ for i, a in ipairs(arg_list) do - local val_18_auto = get_arg_name(a, i) - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + local val_19_ = get_arg_name(a, i) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - arg_name_list = tbl_16_auto + arg_name_list = tbl_17_ end local f_metadata, index0 = get_function_metadata(ast, arg_list, index) if fn_name then @@ -1134,39 +1166,37 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct doc_special("fn", {"name?", "args", "docstring?", "..."}, "Function syntax. May optionally include a name and docstring or a metadata table.\nIf a name is provided, the function will be bound in the current scope.\nWhen called with the wrong number of args, excess args will be discarded\nand lacking args will be nil, use lambda for arity-checked functions.", true) SPECIALS.lua = function(ast, _, parent) compiler.assert(((#ast == 2) or (#ast == 3)), "expected 1 or 2 arguments", ast) - local _474_ + local _524_ do - local _473_ = utils["sym?"](ast[2]) - if (nil ~= _473_) then - _474_ = tostring(_473_) + local _523_0 = utils["sym?"](ast[2]) + if (nil ~= _523_0) then + _524_ = tostring(_523_0) else - _474_ = _473_ + _524_ = _523_0 end end - if ("nil" ~= _474_) then + if ("nil" ~= _524_) then table.insert(parent, {ast = ast, leaf = tostring(ast[2])}) - else end - local _478_ + local _528_ do - local _477_ = utils["sym?"](ast[3]) - if (nil ~= _477_) then - _478_ = tostring(_477_) + local _527_0 = utils["sym?"](ast[3]) + if (nil ~= _527_0) then + _528_ = tostring(_527_0) else - _478_ = _477_ + _528_ = _527_0 end end - if ("nil" ~= _478_) then + if ("nil" ~= _528_) then return tostring(ast[3]) - else - return nil end end local function dot(ast, scope, parent) compiler.assert((1 < #ast), "expected table argument", ast) local len = #ast - local _let_481_ = compiler.compile1(ast[2], scope, parent, {nval = 1}) - local lhs = _let_481_[1] + local lhs_node = compiler.macroexpand(ast[2], scope) + local _531_ = compiler.compile1(lhs_node, scope, parent, {nval = 1}) + local lhs = _531_[1] if (len == 2) then return tostring(lhs) else @@ -1176,12 +1206,12 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct if (utils["string?"](index) and utils["valid-lua-identifier?"](index)) then table.insert(indices, ("." .. index)) else - local _let_482_ = compiler.compile1(index, scope, parent, {nval = 1}) - local index0 = _let_482_[1] + local _532_ = compiler.compile1(index, scope, parent, {nval = 1}) + local index0 = _532_[1] table.insert(indices, ("[" .. tostring(index0) .. "]")) end end - if (tostring(lhs):find("[{\"0-9]") or ("nil" == tostring(lhs))) then + if (not (utils["sym?"](lhs_node) or utils["list?"](lhs_node)) or ("nil" == tostring(lhs_node))) then return ("(" .. tostring(lhs) .. ")" .. table.concat(indices)) else return (tostring(lhs) .. table.concat(indices)) @@ -1195,7 +1225,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct compiler.destructure(ast[2], ast[3], ast, scope, parent, {forceglobal = true, nomulti = true, symtype = "global"}) return nil end - doc_special("global", {"name", "val"}, "Set name as a global with val.") + doc_special("global", {"name", "val"}, "Set name as a global with val. Deprecated.") SPECIALS.set = function(ast, scope, parent) compiler.assert((#ast == 3), "expected name and value", ast) compiler.destructure(ast[2], ast[3], ast, scope, parent, {noundef = true, symtype = "set"}) @@ -1208,49 +1238,62 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return nil end SPECIALS["set-forcibly!"] = set_forcibly_21_2a - local function local_2a(ast, scope, parent) + local function local_2a(ast, scope, parent, opts) + compiler.assert(((0 == opts.nval) or opts.tail), "can't introduce local here", ast) compiler.assert((#ast == 3), "expected name and value", ast) compiler.destructure(ast[2], ast[3], ast, scope, parent, {declaration = true, nomulti = true, symtype = "local"}) return nil end SPECIALS["local"] = local_2a doc_special("local", {"name", "val"}, "Introduce new top-level immutable local.") - SPECIALS.var = function(ast, scope, parent) + SPECIALS.var = function(ast, scope, parent, opts) + compiler.assert(((0 == opts.nval) or opts.tail), "can't introduce var here", ast) compiler.assert((#ast == 3), "expected name and value", ast) compiler.destructure(ast[2], ast[3], ast, scope, parent, {declaration = true, isvar = true, nomulti = true, symtype = "var"}) return nil end doc_special("var", {"name", "val"}, "Introduce new mutable local.") local function kv_3f(t) - local _486_ + local _536_ do - local tbl_16_auto = {} - local i_17_auto = #tbl_16_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ for k in pairs(t) do - local val_18_auto + local val_19_ = nil if ("number" ~= type(k)) then - val_18_auto = k + val_19_ = k else - val_18_auto = nil + val_19_ = nil end - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - _486_ = tbl_16_auto + _536_ = tbl_17_ end - return (_486_)[1] + return _536_[1] end - SPECIALS.let = function(ast, scope, parent, opts) - local bindings = ast[2] - local pre_syms = {} - compiler.assert((utils["table?"](bindings) and not kv_3f(bindings)), "expected binding sequence", bindings) - compiler.assert(((#bindings % 2) == 0), "expected even number of name/value bindings", ast[2]) + SPECIALS.let = function(_539_0, scope, parent, opts) + local _540_ = _539_0 + local _ = _540_[1] + local bindings = _540_[2] + local ast = _540_ + compiler.assert((utils["table?"](bindings) and not kv_3f(bindings)), "expected binding sequence", (bindings or ast[1])) + compiler.assert(((#bindings % 2) == 0), "expected even number of name/value bindings", bindings) compiler.assert((3 <= #ast), "expected body expression", ast[1]) - for _ = 1, (opts.nval or 0) do - table.insert(pre_syms, compiler.gensym(scope)) + local pre_syms = nil + do + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for _0 = 1, (opts.nval or 0) do + local val_19_ = compiler.gensym(scope) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end + end + pre_syms = tbl_17_ end local sub_scope = compiler["make-scope"](scope) local sub_chunk = {} @@ -1267,39 +1310,43 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return (parent or "") end end - local function disambiguate_3f(rootstr, parent) - local function _491_() - local _490_ = get_prev_line(parent) - if (nil ~= _490_) then - local prev_line = _490_ - return prev_line:match("%)$") - else - return nil - end - end - return (rootstr:match("^{") or _491_()) + local function needs_separator_3f(root, prev_line) + return (root:match("^%(") and prev_line and not prev_line:find(" end$")) end SPECIALS.tset = function(ast, scope, parent) compiler.assert((3 < #ast), "expected table, key, and value arguments", ast) - local root = (compiler.compile1(ast[2], scope, parent, {nval = 1}))[1] - local keys = {} - for i = 3, (#ast - 1) do - local _let_493_ = compiler.compile1(ast[i], scope, parent, {nval = 1}) - local key = _let_493_[1] - table.insert(keys, tostring(key)) - end - local value = (compiler.compile1(ast[#ast], scope, parent, {nval = 1}))[1] - local rootstr = tostring(root) - local fmtstr - if disambiguate_3f(rootstr, parent) then - fmtstr = "do end (%s)[%s] = %s" + compiler.assert(((type(ast[2]) ~= "boolean") and (type(ast[2]) ~= "number")), "cannot set field of literal value", ast) + local root = str1(compiler.compile1(ast[2], scope, parent, {nval = 1})) + local root0 = nil + if root:match("^[.{\"]") then + root0 = string.format("(%s)", root) + else + root0 = root + end + local keys = nil + do + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for i = 3, (#ast - 1) do + local val_19_ = str1(compiler.compile1(ast[i], scope, parent, {nval = 1})) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end + end + keys = tbl_17_ + end + local value = str1(compiler.compile1(ast[#ast], scope, parent, {nval = 1})) + local fmtstr = nil + if needs_separator_3f(root0, get_prev_line(parent)) then + fmtstr = "do end %s[%s] = %s" else fmtstr = "%s[%s] = %s" end - return compiler.emit(parent, fmtstr:format(rootstr, table.concat(keys, "]["), tostring(value)), ast) + return compiler.emit(parent, fmtstr:format(root0, table.concat(keys, "]["), value), ast) end - doc_special("tset", {"tbl", "key1", "...", "keyN", "val"}, "Set the value of a table field. Can take additional keys to set\nnested values, but all parents must contain an existing table.") - local function calculate_target(scope, opts) + doc_special("tset", {"tbl", "key1", "...", "keyN", "val"}, "Set the value of a table field. Deprecated in favor of set.") + local function calculate_if_target(scope, opts) if not (opts.tail or opts.target or opts.nval) then return "iife", true, nil elseif (opts.nval and (opts.nval ~= 0) and not opts.target) then @@ -1307,7 +1354,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local target_exprs = {} for i = 1, opts.nval do local s = compiler.gensym(scope) - do end (accum)[i] = s + accum[i] = s target_exprs[i] = utils.expr(s, "sym") end return "target", opts.tail, table.concat(accum, ", "), target_exprs @@ -1317,134 +1364,185 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end local function if_2a(ast, scope, parent, opts) compiler.assert((2 < #ast), "expected condition and body", ast) - local do_scope = compiler["make-scope"](scope) - local branches = {} - local wrapper, inner_tail, inner_target, target_exprs = calculate_target(scope, opts) - local body_opts = {nval = opts.nval, tail = inner_tail, target = inner_target} - local function compile_body(i) - local chunk = {} - local cscope = compiler["make-scope"](do_scope) - compiler["keep-side-effects"](compiler.compile1(ast[i], cscope, chunk, body_opts), chunk, nil, ast[i]) - return {chunk = chunk, scope = cscope} + if ((1 == (#ast % 2)) and (ast[(#ast - 1)] == true)) then + table.remove(ast, (#ast - 1)) end if (1 == (#ast % 2)) then table.insert(ast, utils.sym("nil")) - else end - for i = 2, (#ast - 1), 2 do - local condchunk = {} - local res = compiler.compile1(ast[i], do_scope, condchunk, {nval = 1}) - local cond = res[1] - local branch = compile_body((i + 1)) - branch.cond = cond - branch.condchunk = condchunk - branch.nested = ((i ~= 2) and (next(condchunk, nil) == nil)) - table.insert(branches, branch) - end - local else_branch = compile_body(#ast) - local s = compiler.gensym(scope) - local buffer = {} - local last_buffer = buffer - for i = 1, #branches do - local branch = branches[i] - local fstr - if not branch.nested then - fstr = "if %s then" - else - fstr = "elseif %s then" - end - local cond = tostring(branch.cond) - local cond_line = fstr:format(cond) - if branch.nested then - compiler.emit(last_buffer, branch.condchunk, ast) - else - for _, v in ipairs(branch.condchunk) do - compiler.emit(last_buffer, v, ast) - end - end - compiler.emit(last_buffer, cond_line, ast) - compiler.emit(last_buffer, branch.chunk, ast) - if (i == #branches) then - compiler.emit(last_buffer, "else", ast) - compiler.emit(last_buffer, else_branch.chunk, ast) - compiler.emit(last_buffer, "end", ast) - elseif not (branches[(i + 1)]).nested then - local next_buffer = {} - compiler.emit(last_buffer, "else", ast) - compiler.emit(last_buffer, next_buffer, ast) - compiler.emit(last_buffer, "end", ast) - last_buffer = next_buffer + if (#ast == 2) then + return SPECIALS["do"](utils.list(utils.sym("do"), ast[2]), scope, parent, opts) + else + local do_scope = compiler["make-scope"](scope) + local branches = {} + local wrapper, inner_tail, inner_target, target_exprs = calculate_if_target(scope, opts) + local body_opts = {nval = opts.nval, tail = inner_tail, target = inner_target} + local function compile_body(i) + local chunk = {} + local cscope = compiler["make-scope"](do_scope) + compiler["keep-side-effects"](compiler.compile1(ast[i], cscope, chunk, body_opts), chunk, nil, ast[i]) + return {chunk = chunk, scope = cscope} + end + for i = 2, (#ast - 1), 2 do + local condchunk = {} + local _549_ = compiler.compile1(ast[i], do_scope, condchunk, {nval = 1}) + local cond = _549_[1] + local branch = compile_body((i + 1)) + branch.cond = cond + branch.condchunk = condchunk + branch.nested = ((i ~= 2) and (next(condchunk, nil) == nil)) + table.insert(branches, branch) + end + local else_branch = compile_body(#ast) + local s = compiler.gensym(scope) + local buffer = {} + local last_buffer = buffer + for i = 1, #branches do + local branch = branches[i] + local fstr = nil + if not branch.nested then + fstr = "if %s then" + else + fstr = "elseif %s then" + end + local cond = tostring(branch.cond) + local cond_line = fstr:format(cond) + if branch.nested then + compiler.emit(last_buffer, branch.condchunk, ast) + else + for _, v in ipairs(branch.condchunk) do + compiler.emit(last_buffer, v, ast) + end + end + compiler.emit(last_buffer, cond_line, ast) + compiler.emit(last_buffer, branch.chunk, ast) + if (i == #branches) then + compiler.emit(last_buffer, "else", ast) + compiler.emit(last_buffer, else_branch.chunk, ast) + compiler.emit(last_buffer, "end", ast) + elseif not branches[(i + 1)].nested then + local next_buffer = {} + compiler.emit(last_buffer, "else", ast) + compiler.emit(last_buffer, next_buffer, ast) + compiler.emit(last_buffer, "end", ast) + last_buffer = next_buffer + end + end + if (wrapper == "iife") then + local iifeargs = ((scope.vararg and "...") or "") + compiler.emit(parent, ("local function %s(%s)"):format(tostring(s), iifeargs), ast) + compiler.emit(parent, buffer, ast) + compiler.emit(parent, "end", ast) + return utils.expr(("%s(%s)"):format(tostring(s), iifeargs), "statement") + elseif (wrapper == "none") then + for i = 1, #buffer do + compiler.emit(parent, buffer[i], ast) + end + return {returned = true} else + compiler.emit(parent, ("local %s"):format(inner_target), ast) + for i = 1, #buffer do + compiler.emit(parent, buffer[i], ast) + end + return target_exprs end end - if (wrapper == "iife") then - local iifeargs = ((scope.vararg and "...") or "") - compiler.emit(parent, ("local function %s(%s)"):format(tostring(s), iifeargs), ast) - compiler.emit(parent, buffer, ast) - compiler.emit(parent, "end", ast) - return utils.expr(("%s(%s)"):format(tostring(s), iifeargs), "statement") - elseif (wrapper == "none") then - for i = 1, #buffer do - compiler.emit(parent, buffer[i], ast) - end - return {returned = true} - else - compiler.emit(parent, ("local %s"):format(inner_target), ast) - for i = 1, #buffer do - compiler.emit(parent, buffer[i], ast) - end - return target_exprs - end 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) - local last_item = bindings[(#bindings - 1)] - if ((utils["sym?"](last_item) and (tostring(last_item) == "&until")) or ("until" == last_item)) then - table.remove(bindings, (#bindings - 1)) - return table.remove(bindings) - else - return nil + local function clause_3f(v) + return (utils["string?"](v) or (utils["sym?"](v) and not utils["multi-sym?"](v) and tostring(v):match("^&(.+)"))) + end + local function remove_until_condition(bindings, ast) + local _until = nil + for i = (#bindings - 1), 3, -1 do + local _555_0 = clause_3f(bindings[i]) + if ((_555_0 == false) or (_555_0 == nil)) then + elseif (nil ~= _555_0) then + local clause = _555_0 + compiler.assert(((clause == "until") and not _until), ("unexpected iterator clause: " .. clause), ast) + table.remove(bindings, i) + _until = table.remove(bindings, i) + end + end + return _until + end + local function compile_until(_3fcondition, scope, chunk) + if _3fcondition then + local _557_ = compiler.compile1(_3fcondition, scope, chunk, {nval = 1}) + local condition_lua = _557_[1] + return compiler.emit(chunk, ("if %s then break end"):format(tostring(condition_lua)), utils.expr(_3fcondition, "expression")) end end - local function compile_until(condition, scope, chunk) - if condition then - local _let_502_ = compiler.compile1(condition, scope, chunk, {nval = 1}) - local condition_lua = _let_502_[1] - return compiler.emit(chunk, ("if %s then break end"):format(tostring(condition_lua)), utils.expr(condition, "expression")) + local function iterator_bindings(ast) + local bindings = utils.copy(ast) + local _3funtil = remove_until_condition(bindings, ast) + local iter = table.remove(bindings) + local bindings0 = nil + if (1 == #bindings) then + bindings0 = (utils["list?"](bindings[1]) or bindings) else - return nil + for _, b in ipairs(bindings) do + if utils["list?"](b) then + utils.warn("unexpected parens in iterator", b) + end + end + bindings0 = bindings end + return bindings0, iter, _3funtil end SPECIALS.each = function(ast, scope, parent) compiler.assert((3 <= #ast), "expected body expression", ast[1]) - local binding = compiler.assert(utils["table?"](ast[2]), "expected binding table", ast) - local _ = compiler.assert((2 <= #binding), "expected binding and iterator", binding) - local until_condition = remove_until_condition(binding) - local iter = table.remove(binding, #binding) - local destructures = {} - local new_manglings = {} + compiler.assert(utils["table?"](ast[2]), "expected binding table", ast) local sub_scope = compiler["make-scope"](scope) + local binding, iter, _3funtil_condition = iterator_bindings(ast[2]) + local destructures = {} + local deferred_scope_changes = {manglings = {}, symmeta = {}} + utils.hook("pre-each", ast, sub_scope, binding, iter, _3funtil_condition) local function destructure_binding(v) - compiler.assert(not utils["string?"](v), ("unexpected iterator clause " .. tostring(v)), binding) if utils["sym?"](v) then - return compiler["declare-local"](v, {}, sub_scope, ast, new_manglings) + return compiler["declare-local"](v, sub_scope, ast, nil, deferred_scope_changes) else local raw = utils.sym(compiler.gensym(sub_scope)) - do end (destructures)[raw] = v - return compiler["declare-local"](raw, {}, sub_scope, ast) + destructures[raw] = v + return compiler["declare-local"](raw, sub_scope, ast) + end + end + local bind_vars = nil + do + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for _, b in ipairs(binding) do + local val_19_ = destructure_binding(b) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end end + bind_vars = tbl_17_ end - local bind_vars = utils.map(binding, destructure_binding) local vals = compiler.compile1(iter, scope, parent) - local val_names = utils.map(vals, tostring) + local val_names = nil + do + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for _, v in ipairs(vals) do + local val_19_ = tostring(v) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end + end + val_names = tbl_17_ + end local chunk = {} + compiler.assert(bind_vars[1], "expected binding and iterator", ast) compiler.emit(parent, ("for %s in %s do"):format(table.concat(bind_vars, ", "), table.concat(val_names, ", ")), ast) for raw, args in utils.stablepairs(destructures) do compiler.destructure(args, raw, ast, sub_scope, chunk, {declaration = true, nomulti = true, symtype = "each"}) end - compiler["apply-manglings"](sub_scope, new_manglings, ast) - compile_until(until_condition, sub_scope, chunk) + compiler["apply-deferred-scope-changes"](sub_scope, deferred_scope_changes, ast) + compile_until(_3funtil_condition, sub_scope, chunk) compile_do(ast, sub_scope, chunk, 3) compiler.emit(parent, chunk, ast) return compiler.emit(parent, "end", ast) @@ -1452,13 +1550,13 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct doc_special("each", {"[key value (iterator)]", "..."}, "Runs the body once for each set of values provided by the given iterator.\nMost commonly used with ipairs for sequential tables or pairs for undefined\norder, but can be used with any iterator.", true) local function while_2a(ast, scope, parent) local len1 = #parent - local condition = (compiler.compile1(ast[2], scope, parent, {nval = 1}))[1] + local condition = compiler.compile1(ast[2], scope, parent, {nval = 1})[1] local len2 = #parent local sub_chunk = {} if (len1 ~= len2) then for i = (len1 + 1), len2 do table.insert(sub_chunk, parent[i]) - do end (parent)[i] = nil + parent[i] = nil end compiler.emit(parent, "while true do", ast) compiler.emit(sub_chunk, ("if not %s then break end"):format(condition[1]), ast) @@ -1472,19 +1570,22 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct SPECIALS["while"] = while_2a doc_special("while", {"condition", "..."}, "The classic while loop. Evaluates body until a condition is non-truthy.", true) local function for_2a(ast, scope, parent) - local ranges = compiler.assert(utils["table?"](ast[2]), "expected binding table", ast) - local until_condition = remove_until_condition(ast[2]) - local binding_sym = table.remove(ast[2], 1) + compiler.assert(utils["table?"](ast[2]), "expected binding table", ast) + local ranges = setmetatable(utils.copy(ast[2]), getmetatable(ast[2])) + local until_condition = remove_until_condition(ranges, ast) + local binding_sym = table.remove(ranges, 1) local sub_scope = compiler["make-scope"](scope) local range_args = {} local chunk = {} compiler.assert(utils["sym?"](binding_sym), ("unable to bind %s %s"):format(type(binding_sym), tostring(binding_sym)), ast[2]) compiler.assert((3 <= #ast), "expected body expression", ast[1]) - compiler.assert((#ranges <= 3), "unexpected arguments", ranges[4]) + compiler.assert((#ranges <= 3), "unexpected arguments", ranges) + compiler.assert((1 < #ranges), "expected range to include start and stop", ranges) + utils.hook("pre-for", ast, sub_scope, binding_sym) for i = 1, math.min(#ranges, 3) do - range_args[i] = tostring((compiler.compile1(ranges[i], scope, parent, {nval = 1}))[1]) + range_args[i] = str1(compiler.compile1(ranges[i], scope, parent, {nval = 1})) end - compiler.emit(parent, ("for %s = %s do"):format(compiler["declare-local"](binding_sym, {}, sub_scope, ast), table.concat(range_args, ", ")), ast) + 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) @@ -1492,13 +1593,22 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end SPECIALS["for"] = for_2a doc_special("for", {"[index start stop step?]", "..."}, "Numeric loop construct.\nEvaluates body once for each value between start and stop (inclusive).", true) + local function method_special_type(ast) + if (utils["string?"](ast[3]) and utils["valid-lua-identifier?"](ast[3])) then + return "native" + elseif utils["sym?"](ast[2]) then + return "nonnative" + else + return "binding" + end + end local function native_method_call(ast, _scope, _parent, target, args) - local _let_506_ = ast - local _ = _let_506_[1] - local _0 = _let_506_[2] - local method_string = _let_506_[3] - local call_string - if ((target.type == "literal") or (target.type == "varg") or (target.type == "expression")) then + local _566_ = ast + local _ = _566_[1] + local _0 = _566_[2] + local method_string = _566_[3] + local call_string = nil + if ((target.type == "literal") or (target.type == "varg") or ((target.type == "expression") and not (target[1]):match("[%)%]]$") and not (target[1]):match("%.[%a_][%w_]*$"))) then call_string = "(%s):%s(%s)" else call_string = "%s:%s(%s)" @@ -1506,52 +1616,78 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return utils.expr(string.format(call_string, tostring(target), method_string, table.concat(args, ", ")), "statement") end local function nonnative_method_call(ast, scope, parent, target, args) - local method_string = tostring((compiler.compile1(ast[3], scope, parent, {nval = 1}))[1]) + local method_string = str1(compiler.compile1(ast[3], scope, parent, {nval = 1})) local args0 = {tostring(target), unpack(args)} return utils.expr(string.format("%s[%s](%s)", tostring(target), method_string, table.concat(args0, ", ")), "statement") end - local function double_eval_protected_method_call(ast, scope, parent, target, args) - local method_string = tostring((compiler.compile1(ast[3], scope, parent, {nval = 1}))[1]) - local call = "(function(tgt, m, ...) return tgt[m](tgt, ...) end)(%s, %s)" - table.insert(args, 1, method_string) - return utils.expr(string.format(call, tostring(target), table.concat(args, ", ")), "statement") + local function binding_method_call(ast, scope, parent, target, args) + local method_string = str1(compiler.compile1(ast[3], scope, parent, {nval = 1})) + local target_local = compiler.gensym(scope, "tgt") + local args0 = {target_local, unpack(args)} + compiler.emit(parent, string.format("local %s = %s", target_local, tostring(target))) + return utils.expr(string.format("(%s)[%s](%s)", target_local, method_string, table.concat(args0, ", ")), "statement") end local function method_call(ast, scope, parent) compiler.assert((2 < #ast), "expected at least 2 arguments", ast) - local _let_508_ = compiler.compile1(ast[2], scope, parent, {nval = 1}) - local target = _let_508_[1] + local _568_ = compiler.compile1(ast[2], scope, parent, {nval = 1}) + local target = _568_[1] local args = {} for i = 4, #ast do - local subexprs - local _509_ + local subexprs = nil + local _569_ if (i ~= #ast) then - _509_ = 1 + _569_ = 1 else - _509_ = nil + _569_ = nil + end + subexprs = compiler.compile1(ast[i], scope, parent, {nval = _569_}) + local tbl_17_ = args + local i_18_ = #tbl_17_ + for _, subexpr in ipairs(subexprs) do + local val_19_ = tostring(subexpr) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end end - subexprs = compiler.compile1(ast[i], scope, parent, {nval = _509_}) - utils.map(subexprs, tostring, args) end - if (utils["string?"](ast[3]) and utils["valid-lua-identifier?"](ast[3])) then + local _572_0 = method_special_type(ast) + if (_572_0 == "native") then return native_method_call(ast, scope, parent, target, args) - elseif (target.type == "sym") then + elseif (_572_0 == "nonnative") then return nonnative_method_call(ast, scope, parent, target, args) - else - return double_eval_protected_method_call(ast, scope, parent, target, args) + elseif (_572_0 == "binding") then + return binding_method_call(ast, scope, parent, target, args) end end SPECIALS[":"] = method_call doc_special(":", {"tbl", "method-name", "..."}, "Call the named method on tbl with the provided args.\nMethod name doesn't have to be known at compile-time; if it is, use\n(tbl:method-name ...) instead.") SPECIALS.comment = function(ast, _, parent) - local els = {} - for i = 2, #ast do - table.insert(els, view(ast[i], {["one-line?"] = true})) + local c = nil + local _574_ + do + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for i, elt in ipairs(ast) do + local val_19_ = nil + if (i ~= 1) then + val_19_ = view(elt, {["one-line?"] = true}) + else + val_19_ = nil + end + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end + end + _574_ = tbl_17_ end - return compiler.emit(parent, ("--[[ " .. table.concat(els, " ") .. " ]]"), ast) + c = table.concat(_574_, " "):gsub("%]%]", "]\\]") + return compiler.emit(parent, ("--[[ " .. c .. " ]]"), ast) end doc_special("comment", {"..."}, "Comment which will be emitted in Lua output.", true) local function hashfn_max_used(f_scope, i, max) - local max0 + local max0 = nil if f_scope.symmeta[("$" .. i)].used then max0 = i else @@ -1565,38 +1701,41 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end SPECIALS.hashfn = function(ast, scope, parent) compiler.assert((#ast == 2), "expected one argument", ast) - local f_scope + local f_scope = nil do - local _514_ = compiler["make-scope"](scope) - do end (_514_)["vararg"] = false - _514_["hashfn"] = true - f_scope = _514_ + local _579_0 = compiler["make-scope"](scope) + _579_0["vararg"] = false + _579_0["hashfn"] = true + f_scope = _579_0 end local f_chunk = {} local name = compiler.gensym(scope) local symbol = utils.sym(name) local args = {} - compiler["declare-local"](symbol, {}, scope, ast) + compiler["declare-local"](symbol, scope, ast) for i = 1, 9 do - args[i] = compiler["declare-local"](utils.sym(("$" .. i)), {}, f_scope, ast) + args[i] = compiler["declare-local"](utils.sym(("$" .. i)), f_scope, ast) end - local function walker(idx, node, parent_node) - if (utils["sym?"](node) and (tostring(node) == "$...")) then - parent_node[idx] = utils.varg() + local function walker(idx, node, _3fparent_node) + if utils["sym?"](node, "$...") then f_scope.vararg = true - return nil + if _3fparent_node then + _3fparent_node[idx] = utils.varg() + return nil + else + return utils.varg() + end else - return (("table" == type(node)) and (utils.sym("hashfn") ~= node[1]) and (utils["list?"](node) or utils["table?"](node))) + return ((utils["list?"](node) and (not _3fparent_node or not utils["sym?"](node[1], "hashfn"))) or utils["table?"](node)) end end - utils["walk-tree"](ast[2], walker) + utils["walk-tree"](ast, walker) compiler.compile1(ast[2], f_scope, f_chunk, {tail = true}) local max_used = hashfn_max_used(f_scope, 1, 0) if f_scope.vararg then compiler.assert((max_used == 0), "$ and $... in hashfn are mutually exclusive", ast) - else end - local arg_str + local arg_str = nil if f_scope.vararg then arg_str = tostring(utils.varg()) else @@ -1608,78 +1747,164 @@ 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 maybe_short_circuit_protect(ast, i, name, _518_) - local _arg_519_ = _518_ - local mac = _arg_519_["macros"] - local call = (utils["list?"](ast) and tostring(ast[1])) - if ((("or" == name) or ("and" == name)) and (1 < i) and (mac[call] or ("set" == call) or ("tset" == call) or ("global" == call))) then - return utils.list(utils.sym("do"), ast) + local function comparator_special_type(ast) + if (3 == #ast) then + return "native" + elseif utils["every?"]({unpack(ast, 3, (#ast - 1))}, utils["idempotent-expr?"]) then + return "idempotent" else - return ast + return "binding" end end - local function arithmetic_special(name, zero_arity, unary_prefix, ast, scope, parent) - local len = #ast - local operands = {} - local padded_op = (" " .. name .. " ") - for i = 2, len do - local subast = maybe_short_circuit_protect(ast[i], i, name, scope) - local subexprs = compiler.compile1(subast, scope, parent) - if (i == len) then - utils.map(subexprs, tostring, operands) + local function short_circuit_safe_3f(x, scope) + if (("table" ~= type(x)) or utils["sym?"](x) or utils["varg?"](x)) then + return true + elseif utils["table?"](x) then + local ok = true + for k, v in pairs(x) do + if not ok then break end + ok = (short_circuit_safe_3f(v, scope) and short_circuit_safe_3f(k, scope)) + end + return ok + elseif utils["list?"](x) then + if utils["sym?"](x[1]) then + local _585_0 = str1(x) + if ((_585_0 == "fn") or (_585_0 == "hashfn") or (_585_0 == "let") or (_585_0 == "local") or (_585_0 == "var") or (_585_0 == "set") or (_585_0 == "tset") or (_585_0 == "if") or (_585_0 == "each") or (_585_0 == "for") or (_585_0 == "while") or (_585_0 == "do") or (_585_0 == "lua") or (_585_0 == "global")) then + return false + elseif (((_585_0 == "<") or (_585_0 == ">") or (_585_0 == "<=") or (_585_0 == ">=") or (_585_0 == "=") or (_585_0 == "not=") or (_585_0 == "~=")) and (comparator_special_type(x) == "binding")) then + return false + else + local function _586_() + return (1 ~= x[2]) + end + if ((_585_0 == "pick-values") and _586_()) then + return false + else + local function _587_() + local call = _585_0 + return scope.macros[call] + end + if ((nil ~= _585_0) and _587_()) then + local call = _585_0 + return false + else + local function _588_() + return (method_special_type(x) == "binding") + end + if ((_585_0 == ":") and _588_()) then + return false + else + local _ = _585_0 + local ok = true + for i = 2, #x do + if not ok then break end + ok = short_circuit_safe_3f(x[i], scope) + end + return ok + end + end + end + end else - table.insert(operands, tostring(subexprs[1])) + local ok = true + for _, v in ipairs(x) do + if not ok then break end + ok = short_circuit_safe_3f(v, scope) + end + return ok end end - local _522_ = #operands - if (_522_ == 0) then - local _524_ - do - local _523_ = zero_arity - compiler.assert(_523_, "Expected more than 0 arguments", ast) - _524_ = _523_ + end + local function operator_special_result(ast, zero_arity, unary_prefix, padded_op, operands) + local _592_0 = #operands + if (_592_0 == 0) then + if zero_arity then + return utils.expr(zero_arity, "literal") + else + return compiler.assert(false, "Expected more than 0 arguments", ast) end - return utils.expr(_524_, "literal") - elseif (_522_ == 1) then + elseif (_592_0 == 1) then if unary_prefix then return ("(" .. unary_prefix .. padded_op .. operands[1] .. ")") else return operands[1] end - elseif true then - local _ = _522_ - return ("(" .. table.concat(operands, padded_op) .. ")") else - return nil + local _ = _592_0 + return ("(" .. table.concat(operands, padded_op) .. ")") + end + end + local function emit_short_circuit_if(ast, scope, parent, name, subast, accumulator, expr_string, setter) + if (accumulator ~= expr_string) then + compiler.emit(parent, string.format(setter, accumulator, expr_string), ast) + end + local function _597_() + if (name == "and") then + return accumulator + else + return ("not " .. accumulator) + end + end + compiler.emit(parent, ("if %s then"):format(_597_()), subast) + do + local chunk = {} + compiler.compile1(subast, scope, chunk, {nval = 1, target = accumulator}) + compiler.emit(parent, chunk) end + return compiler.emit(parent, "end") + end + local function operator_special(name, zero_arity, unary_prefix, ast, scope, parent) + compiler.assert(not ((#ast == 2) and utils["varg?"](ast[2])), "tried to use vararg with operator", ast) + local padded_op = (" " .. name .. " ") + local operands, accumulator = {} + if utils["call-of?"](ast[#ast], "values") then + utils.warn("multiple values in operators are deprecated", ast) + end + for subast in iter_args(ast) do + if ((nil ~= next(operands)) and ((name == "or") or (name == "and")) and not short_circuit_safe_3f(subast, scope)) then + local expr_string = table.concat(operands, padded_op) + local setter = nil + if accumulator then + setter = "%s = %s" + else + setter = "local %s = %s" + end + if not accumulator then + accumulator = compiler.gensym(scope, name) + end + emit_short_circuit_if(ast, scope, parent, name, subast, accumulator, expr_string, setter) + operands = {accumulator} + else + table.insert(operands, str1(compiler.compile1(subast, scope, parent, {nval = 1}))) + end + end + return operator_special_result(ast, zero_arity, unary_prefix, padded_op, operands) end local function define_arithmetic_special(name, zero_arity, unary_prefix, _3flua_name) - local _530_ + local _603_ do - local _527_ = (_3flua_name or name) - local _528_ = zero_arity - local _529_ = unary_prefix - local function _531_(...) - return arithmetic_special(_527_, _528_, _529_, ...) + local _602_0 = (_3flua_name or name) + local function _604_(...) + return operator_special(_602_0, zero_arity, unary_prefix, ...) end - _530_ = _531_ + _603_ = _604_ end - SPECIALS[name] = _530_ + SPECIALS[name] = _603_ return doc_special(name, {"a", "b", "..."}, "Arithmetic operator; works the same as Lua but accepts more arguments.") end - define_arithmetic_special("+", "0") + define_arithmetic_special("+", "0", "0") define_arithmetic_special("..", "''") define_arithmetic_special("^") define_arithmetic_special("-", nil, "") - define_arithmetic_special("*", "1") + define_arithmetic_special("*", "1", "1") define_arithmetic_special("%") define_arithmetic_special("/", nil, "1") define_arithmetic_special("//", nil, "1") SPECIALS["or"] = function(ast, scope, parent) - return arithmetic_special("or", "false", nil, ast, scope, parent) + return operator_special("or", "false", nil, ast, scope, parent) end SPECIALS["and"] = function(ast, scope, parent) - return arithmetic_special("and", "true", nil, ast, scope, parent) + return operator_special("and", "true", nil, ast, scope, parent) end doc_special("and", {"a", "b", "..."}, "Boolean operator; works the same as Lua but accepts more arguments.") doc_special("or", {"a", "b", "..."}, "Boolean operator; works the same as Lua but accepts more arguments.") @@ -1692,15 +1917,23 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local padded_native_name = (" " .. native_name .. " ") local prefixed_lib_name = ("bit." .. lib_name) for i = 2, len do - local subexprs - local _532_ + local subexprs = nil + local _605_ if (i ~= len) then - _532_ = 1 + _605_ = 1 else - _532_ = nil + _605_ = nil + end + subexprs = compiler.compile1(ast[i], scope, parent, {nval = _605_}) + local tbl_17_ = operands + local i_18_ = #tbl_17_ + for _, s in ipairs(subexprs) do + local val_19_ = tostring(s) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end end - subexprs = compiler.compile1(ast[i], scope, parent, {nval = _532_}) - utils.map(subexprs, tostring, operands) end if (#operands == 1) then if utils.root.options.useBitLib then @@ -1718,23 +1951,15 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end end local function define_bitop_special(name, zero_arity, unary_prefix, native) - local _542_ - do - local _538_ = native - local _539_ = name - local _540_ = zero_arity - local _541_ = unary_prefix - local function _543_(...) - return bitop_special(_538_, _539_, _540_, _541_, ...) - end - _542_ = _543_ + local function _612_(...) + return bitop_special(native, name, zero_arity, unary_prefix, ...) end - SPECIALS[name] = _542_ + SPECIALS[name] = _612_ return nil end define_bitop_special("lshift", nil, "1", "<<") define_bitop_special("rshift", nil, "1", ">>") - define_bitop_special("band", "0", "0", "&") + define_bitop_special("band", "-1", "-1", "&") 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.") @@ -1742,84 +1967,106 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct 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.") + SPECIALS.bnot = function(ast, scope, parent) + compiler.assert((#ast == 2), "expected one argument", ast) + local _613_ = compiler.compile1(ast[2], scope, parent, {nval = 1}) + local value = _613_[1] + if utils.root.options.useBitLib then + return ("bit.bnot(" .. tostring(value) .. ")") + else + return ("~(" .. tostring(value) .. ")") + end + end + doc_special("bnot", {"x"}, "Bitwise negation; only works in Lua 5.3+ or LuaJIT with the --use-bit-lib flag.") doc_special("..", {"a", "b", "..."}, "String concatenation operator; works the same as Lua but accepts more arguments.") - local function native_comparator(op, _544_, scope, parent) - local _arg_545_ = _544_ - local _ = _arg_545_[1] - local lhs_ast = _arg_545_[2] - local rhs_ast = _arg_545_[3] - local _let_546_ = compiler.compile1(lhs_ast, scope, parent, {nval = 1}) - local lhs = _let_546_[1] - local _let_547_ = compiler.compile1(rhs_ast, scope, parent, {nval = 1}) - local rhs = _let_547_[1] + local function native_comparator(op, _615_0, scope, parent) + local _616_ = _615_0 + local _ = _616_[1] + local lhs_ast = _616_[2] + local rhs_ast = _616_[3] + local _617_ = compiler.compile1(lhs_ast, scope, parent, {nval = 1}) + local lhs = _617_[1] + local _618_ = compiler.compile1(rhs_ast, scope, parent, {nval = 1}) + local rhs = _618_[1] return string.format("(%s %s %s)", tostring(lhs), op, tostring(rhs)) end local function idempotent_comparator(op, chain_op, ast, scope, parent) - local vals + local vals = nil do - local tbl_16_auto = {} - local i_17_auto = #tbl_16_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ for i = 2, #ast do - local val_18_auto = tostring((compiler.compile1(ast[i], scope, parent, {nval = 1}))[1]) - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + local val_19_ = str1(compiler.compile1(ast[i], scope, parent, {nval = 1})) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - vals = tbl_16_auto + vals = tbl_17_ end - local comparisons + local comparisons = nil do - local tbl_16_auto = {} - local i_17_auto = #tbl_16_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ for i = 1, (#vals - 1) do - local val_18_auto = string.format("(%s %s %s)", vals[i], op, vals[(i + 1)]) - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + local val_19_ = string.format("(%s %s %s)", vals[i], op, vals[(i + 1)]) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - comparisons = tbl_16_auto + comparisons = tbl_17_ end local chain = string.format(" %s ", (chain_op or "and")) - return table.concat(comparisons, chain) + return ("(" .. table.concat(comparisons, chain) .. ")") end - local function double_eval_protected_comparator(op, chain_op, ast, scope, parent) - local arglist = {} - local comparisons = {} + local function binding_comparator(op, chain_op, ast, scope, parent) + local binding_left = {} + local binding_right = {} local vals = {} local chain = string.format(" %s ", (chain_op or "and")) for i = 2, #ast do - table.insert(arglist, tostring(compiler.gensym(scope))) - table.insert(vals, tostring((compiler.compile1(ast[i], scope, parent, {nval = 1}))[1])) + local compiled = str1(compiler.compile1(ast[i], scope, parent, {nval = 1})) + if (utils["idempotent-expr?"](ast[i]) or (i == 2) or (i == #ast)) then + table.insert(vals, compiled) + else + local my_sym = compiler.gensym(scope) + table.insert(binding_left, my_sym) + table.insert(binding_right, compiled) + table.insert(vals, my_sym) + end end + compiler.emit(parent, string.format("local %s = %s", table.concat(binding_left, ", "), table.concat(binding_right, ", "), ast)) + local _622_ do - local tbl_16_auto = comparisons - local i_17_auto = #tbl_16_auto - for i = 1, (#arglist - 1) do - local val_18_auto = string.format("(%s %s %s)", arglist[i], op, arglist[(i + 1)]) - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for i = 1, (#vals - 1) do + local val_19_ = string.format("(%s %s %s)", vals[i], op, vals[(i + 1)]) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end + _622_ = tbl_17_ end - return string.format("(function(%s) return %s end)(%s)", table.concat(arglist, ","), table.concat(comparisons, chain), table.concat(vals, ",")) + return ("(" .. table.concat(_622_, chain) .. ")") end local function define_comparator_special(name, _3flua_op, _3fchain_op) do local op = (_3flua_op or name) local function opfn(ast, scope, parent) compiler.assert((2 < #ast), "expected at least two arguments", ast) - if (3 == #ast) then + local _624_0 = comparator_special_type(ast) + if (_624_0 == "native") then return native_comparator(op, ast, scope, parent) - elseif utils["every?"](utils["idempotent-expr?"], {unpack(ast, 2)}) then + elseif (_624_0 == "idempotent") then return idempotent_comparator(op, _3fchain_op, ast, scope, parent) + elseif (_624_0 == "binding") then + return binding_comparator(op, _3fchain_op, ast, scope, parent) else - return double_eval_protected_comparator(op, _3fchain_op, ast, scope, parent) + local _ = _624_0 + return error("internal compiler error. please report this to the fennel devs.") end end SPECIALS[name] = opfn @@ -1836,18 +2083,16 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local function opfn(ast, scope, parent) compiler.assert((#ast == 2), "expected one argument", ast) local tail = compiler.compile1(ast[2], scope, parent, {nval = 1}) - return ((_3frealop or op) .. tostring(tail[1])) + return ((_3frealop or op) .. str1(tail)) end SPECIALS[op] = opfn return nil end 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+ or LuaJIT with the --use-bit-lib flag.") define_unary_special("length", "#") doc_special("length", {"x"}, "Returns the length of a table or string.") - do end (SPECIALS)["~="] = SPECIALS["not="] + SPECIALS["~="] = SPECIALS["not="] SPECIALS["#"] = SPECIALS.length SPECIALS.quote = function(ast, scope, parent) compiler.assert((#ast == 2), "expected one argument", ast) @@ -1856,7 +2101,6 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct this_scope = this_scope.parent if (this_scope == compiler.scopes.compiler) then runtime = false - else end end return compiler["do-quote"](ast[2], scope, parent, runtime) @@ -1870,26 +2114,25 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end local safe_require = nil local function safe_compiler_env() - local _554_ + local _628_ do - local _553_ = rawget(_G, "utf8") - if (nil ~= _553_) then - _554_ = utils.copy(_553_) + local _627_0 = rawget(_G, "utf8") + if (nil ~= _627_0) then + _628_ = utils.copy(_627_0) else - _554_ = _553_ + _628_ = _627_0 end end - return {table = utils.copy(table), math = utils.copy(math), string = utils.copy(string), pairs = utils.stablepairs, ipairs = ipairs, select = select, tostring = tostring, tonumber = tonumber, bit = rawget(_G, "bit"), pcall = pcall, xpcall = xpcall, next = next, print = print, type = type, assert = assert, error = error, setmetatable = setmetatable, getmetatable = safe_getmetatable, require = safe_require, rawlen = rawget(_G, "rawlen"), rawget = rawget, rawset = rawset, rawequal = rawequal, _VERSION = _VERSION, utf8 = _554_} + return {_VERSION = _VERSION, assert = assert, bit = rawget(_G, "bit"), error = error, getmetatable = safe_getmetatable, ipairs = ipairs, math = utils.copy(math), next = next, pairs = utils.stablepairs, 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, utf8 = _628_, xpcall = xpcall} end local function combined_mt_pairs(env) local combined = {} - local _let_556_ = getmetatable(env) - local __index = _let_556_["__index"] + local _630_ = getmetatable(env) + local __index = _630_["__index"] if ("table" == type(__index)) then for k, v in pairs(__index) do combined[k] = v end - else end for k, v in next, env, nil do combined[k] = v @@ -1897,61 +2140,58 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return next, combined, nil end local function make_compiler_env(ast, scope, parent, _3fopts) - local provided + local provided = nil do - local _558_ = (_3fopts or utils.root.options) - if ((_G.type(_558_) == "table") and ((_558_)["compiler-env"] == "strict")) then + local _632_0 = (_3fopts or utils.root.options) + if ((_G.type(_632_0) == "table") and (_632_0["compiler-env"] == "strict")) then provided = safe_compiler_env() - elseif ((_G.type(_558_) == "table") and (nil ~= (_558_).compilerEnv)) then - local compilerEnv = (_558_).compilerEnv + elseif ((_G.type(_632_0) == "table") and (nil ~= _632_0.compilerEnv)) then + local compilerEnv = _632_0.compilerEnv provided = compilerEnv - elseif ((_G.type(_558_) == "table") and (nil ~= (_558_)["compiler-env"])) then - local compiler_env = (_558_)["compiler-env"] + elseif ((_G.type(_632_0) == "table") and (nil ~= _632_0["compiler-env"])) then + local compiler_env = _632_0["compiler-env"] provided = compiler_env - elseif true then - local _ = _558_ - provided = safe_compiler_env(false) else - provided = nil + local _ = _632_0 + provided = safe_compiler_env() end end - local env - local function _560_(base) - return utils.sym(compiler.gensym((compiler.scopes.macro or scope), base)) - end - local function _561_() + local env = nil + local function _634_() return compiler.scopes.macro end - local function _562_(symbol) + local function _635_(symbol) compiler.assert(compiler.scopes.macro, "must call from macro", ast) return compiler.scopes.macro.manglings[tostring(symbol)] end - local function _563_(form) + local function _636_(base) + return utils.sym(compiler.gensym((compiler.scopes.macro or scope), base)) + end + local function _637_(form) compiler.assert(compiler.scopes.macro, "must call from macro", ast) return compiler.macroexpand(form, compiler.scopes.macro) end - env = {_AST = ast, _CHUNK = parent, _IS_COMPILER = true, _SCOPE = scope, _SPECIALS = compiler.scopes.global.specials, _VARARG = utils.varg(), ["macro-loaded"] = macro_loaded, unpack = unpack, ["assert-compile"] = compiler.assert, view = view, version = utils.version, metadata = compiler.metadata, ["ast-source"] = utils["ast-source"], list = utils.list, ["list?"] = utils["list?"], ["table?"] = utils["table?"], sequence = utils.sequence, ["sequence?"] = utils["sequence?"], sym = utils.sym, ["sym?"] = utils["sym?"], ["multi-sym?"] = utils["multi-sym?"], comment = utils.comment, ["comment?"] = utils["comment?"], ["varg?"] = utils["varg?"], gensym = _560_, ["get-scope"] = _561_, ["in-scope?"] = _562_, macroexpand = _563_} + env = {["assert-compile"] = compiler.assert, ["ast-source"] = utils["ast-source"], ["comment?"] = utils["comment?"], ["fennel-module-name"] = fennel_module_name, ["get-scope"] = _634_, ["in-scope?"] = _635_, ["list?"] = utils["list?"], ["macro-loaded"] = macro_loaded, ["multi-sym?"] = utils["multi-sym?"], ["sequence?"] = utils["sequence?"], ["sym?"] = utils["sym?"], ["table?"] = utils["table?"], ["varg?"] = utils["varg?"], _AST = ast, _CHUNK = parent, _IS_COMPILER = true, _SCOPE = scope, _SPECIALS = compiler.scopes.global.specials, _VARARG = utils.varg(), comment = utils.comment, gensym = _636_, list = utils.list, macroexpand = _637_, sequence = utils.sequence, sym = utils.sym, unpack = unpack, version = utils.version, view = view} env._G = env return setmetatable(env, {__index = provided, __newindex = provided, __pairs = combined_mt_pairs}) end - local function _565_(...) - local tbl_16_auto = {} - local i_17_auto = #tbl_16_auto + local function _638_(...) + local tbl_17_ = {} + local i_18_ = #tbl_17_ for c in string.gmatch((package.config or ""), "([^\n]+)") do - local val_18_auto = c - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + local val_19_ = c + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - return tbl_16_auto + return tbl_17_ end - local _local_564_ = _565_(...) - local dirsep = _local_564_[1] - local pathsep = _local_564_[2] - local pathmark = _local_564_[3] - local pkg_config = {dirsep = (dirsep or "/"), pathmark = (pathmark or ";"), pathsep = (pathsep or "?")} + local _640_ = _638_(...) + local dirsep = _640_[1] + local pathsep = _640_[2] + local pathmark = _640_[3] + local pkg_config = {dirsep = (dirsep or "/"), pathmark = (pathmark or "?"), pathsep = (pathsep or ";")} local function escapepat(str) return string.gsub(str, "[^%w]", "%%%1") end @@ -1963,40 +2203,36 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local function try_path(path) local filename = path:gsub(escapepat(pkg_config.pathmark), no_dot_module) local filename2 = path:gsub(escapepat(pkg_config.pathmark), modulename) - local _567_ = (io.open(filename) or io.open(filename2)) - if (nil ~= _567_) then - local file = _567_ + local _641_0 = (io.open(filename) or io.open(filename2)) + if (nil ~= _641_0) then + local file = _641_0 file:close() return filename - elseif true then - local _ = _567_ - return nil, ("no file '" .. filename .. "'") else - return nil + local _ = _641_0 + return nil, ("no file '" .. filename .. "'") end end local function find_in_path(start, _3ftried_paths) - local _569_ = fullpath:match(pattern, start) - if (nil ~= _569_) then - local path = _569_ - local _570_, _571_ = try_path(path) - if (nil ~= _570_) then - local filename = _570_ + local _643_0 = fullpath:match(pattern, start) + if (nil ~= _643_0) then + local path = _643_0 + local _644_0, _645_0 = try_path(path) + if (nil ~= _644_0) then + local filename = _644_0 return filename - elseif ((_570_ == nil) and (nil ~= _571_)) then - local error = _571_ - local function _573_() - local _572_ = (_3ftried_paths or {}) - table.insert(_572_, error) - return _572_ + elseif ((_644_0 == nil) and (nil ~= _645_0)) then + local error = _645_0 + local function _647_() + local _646_0 = (_3ftried_paths or {}) + table.insert(_646_0, error) + return _646_0 end - return find_in_path((start + #path + 1), _573_()) - else - return nil + return find_in_path((start + #path + 1), _647_()) end - elseif true then - local _ = _569_ - local function _575_() + else + local _ = _643_0 + local function _649_() local tried_paths = table.concat((_3ftried_paths or {}), "\n\9") if (_VERSION < "Lua 5.4") then return ("\n\9" .. tried_paths) @@ -2004,41 +2240,31 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return tried_paths end end - return nil, _575_() - else - return nil + return nil, _649_() end end return find_in_path(1) end local function make_searcher(_3foptions) - local function _578_(module_name) + local function _652_(module_name) local opts = utils.copy(utils.root.options) for k, v in pairs((_3foptions or {})) do opts[k] = v end opts["module-name"] = module_name - local _579_, _580_ = search_module(module_name) - if (nil ~= _579_) then - local filename = _579_ - local _583_ - do - local _581_ = filename - local _582_ = opts - local function _584_(...) - return utils["fennel-module"].dofile(_581_, _582_, ...) - end - _583_ = _584_ - end - return _583_, filename - elseif ((_579_ == nil) and (nil ~= _580_)) then - local error = _580_ + local _653_0, _654_0 = search_module(module_name) + if (nil ~= _653_0) then + local filename = _653_0 + local function _655_(...) + return utils["fennel-module"].dofile(filename, opts, ...) + end + return _655_, filename + elseif ((_653_0 == nil) and (nil ~= _654_0)) then + local error = _654_0 return error - else - return nil end end - return _578_ + return _652_ end local function dofile_with_searcher(fennel_macro_searcher, filename, opts, ...) local searchers = (package.loaders or package.searchers or {}) @@ -2048,116 +2274,104 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct return m end local function fennel_macro_searcher(module_name) - local opts + local opts = nil do - local _586_ = utils.copy(utils.root.options) - do end (_586_)["module-name"] = module_name - _586_["env"] = "_COMPILER" - _586_["requireAsInclude"] = false - _586_["allowedGlobals"] = nil - opts = _586_ - end - local _587_ = search_module(module_name, utils["fennel-module"]["macro-path"]) - if (nil ~= _587_) then - local filename = _587_ - local _588_ + local _657_0 = utils.copy(utils.root.options) + _657_0["module-name"] = module_name + _657_0["env"] = "_COMPILER" + _657_0["requireAsInclude"] = false + _657_0["allowedGlobals"] = nil + opts = _657_0 + end + local _658_0 = search_module(module_name, utils["fennel-module"]["macro-path"]) + if (nil ~= _658_0) then + local filename = _658_0 + local _659_ if (opts["compiler-env"] == _G) then - local _589_ = fennel_macro_searcher - local _590_ = filename - local _591_ = opts - local function _593_(...) - return dofile_with_searcher(_589_, _590_, _591_, ...) + local function _660_(...) + return dofile_with_searcher(fennel_macro_searcher, filename, opts, ...) end - _588_ = _593_ + _659_ = _660_ else - local _594_ = filename - local _595_ = opts - local function _597_(...) - return utils["fennel-module"].dofile(_594_, _595_, ...) + local function _661_(...) + return utils["fennel-module"].dofile(filename, opts, ...) end - _588_ = _597_ + _659_ = _661_ end - return _588_, filename - else - return nil + return _659_, filename end end local function lua_macro_searcher(module_name) - local _600_ = search_module(module_name, package.path) - if (nil ~= _600_) then - local filename = _600_ - local code + local _664_0 = search_module(module_name, package.path) + if (nil ~= _664_0) then + local filename = _664_0 + local code = nil do local f = io.open(filename) - local function close_handlers_8_auto(ok_9_auto, ...) + local function close_handlers_10_(ok_11_, ...) f:close() - if ok_9_auto then + if ok_11_ then return ... else return error(..., 0) end end - local function _602_() + local function _666_() return assert(f:read("*a")) end - code = close_handlers_8_auto(_G.xpcall(_602_, (package.loaded.fennel or debug).traceback)) + code = close_handlers_10_(_G.xpcall(_666_, (package.loaded.fennel or debug).traceback)) end local chunk = load_code(code, make_compiler_env(), filename) return chunk, filename - else - return nil end end local macro_searchers = {fennel_macro_searcher, lua_macro_searcher} local function search_macro_module(modname, n) - local _604_ = macro_searchers[n] - if (nil ~= _604_) then - local f = _604_ - local _605_, _606_ = f(modname) - if ((nil ~= _605_) and true) then - local loader = _605_ - local _3ffilename = _606_ + local _668_0 = macro_searchers[n] + if (nil ~= _668_0) then + local f = _668_0 + local _669_0, _670_0 = f(modname) + if ((nil ~= _669_0) and true) then + local loader = _669_0 + local _3ffilename = _670_0 return loader, _3ffilename - elseif true then - local _ = _605_ - return search_macro_module(modname, (n + 1)) else - return nil + local _ = _669_0 + return search_macro_module(modname, (n + 1)) end - else - return nil end end local function sandbox_fennel_module(modname) if ((modname == "fennel.macros") or (package and package.loaded and ("table" == type(package.loaded[modname])) and (package.loaded[modname].metadata == compiler.metadata))) then - return {metadata = compiler.metadata, view = view} - else - return nil + local function _673_(_, ...) + return (compiler.metadata):setall(...) + end + return {metadata = {setall = _673_}, view = view} end end - local function _610_(modname) - local function _611_() + local function _675_(modname) + local function _676_() local loader, filename = search_macro_module(modname, 1) compiler.assert(loader, (modname .. " module not found.")) - do end (macro_loaded)[modname] = loader(modname, filename) + macro_loaded[modname] = loader(modname, filename) return macro_loaded[modname] end - return (macro_loaded[modname] or sandbox_fennel_module(modname) or _611_()) + return (macro_loaded[modname] or sandbox_fennel_module(modname) or _676_()) end - safe_require = _610_ + safe_require = _675_ 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 compiler.assert((type(v) == "function"), "expected each macro to be function", ast) compiler["check-binding-valid"](utils.sym(k), scope, ast, {["macro?"] = true}) - do end (scope.macros)[k] = v + scope.macros[k] = v end return nil end - local function resolve_module_name(_612_, _scope, _parent, opts) - local _arg_613_ = _612_ - local filename = _arg_613_["filename"] - local second = _arg_613_[2] + local function resolve_module_name(_677_0, _scope, _parent, opts) + local _678_ = _677_0 + local second = _678_[2] + local filename = _678_["filename"] local filename0 = (filename or (utils["table?"](second) and second.filename)) local module_name = utils.root.options["module-name"] local modexpr = compiler.compile(second, opts) @@ -2171,28 +2385,26 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct if not macro_loaded[modname] then local loader, filename = search_macro_module(modname, 1) compiler.assert(loader, (modname .. " module not found."), ast) - do end (macro_loaded)[modname] = compiler.assert(utils["table?"](loader(modname, filename)), "expected macros to be table", (_3freal_ast or ast)) - else + macro_loaded[modname] = compiler.assert(utils["table?"](loader(modname, filename)), "expected macros to be table", (_3freal_ast or ast)) end - if ("import-macros" == tostring(ast[1])) then + if ("import-macros" == str1(ast)) then return macro_loaded[modname] else - return add_macros(macro_loaded[modname], ast, scope, parent) + return add_macros(macro_loaded[modname], ast, scope) end end - doc_special("require-macros", {"macro-module-name"}, "Load given module and use its contents as macro definitions in current scope.\nMacro module should return a table of macro functions with string keys.\nConsider using import-macros instead as it is more flexible.") + doc_special("require-macros", {"macro-module-name"}, "Load given module and use its contents as macro definitions in current scope.\nDeprecated.") local function emit_included_fennel(src, path, opts, sub_chunk) local subscope = compiler["make-scope"](utils.root.scope.parent) local forms = {} if utils.root.options.requireAsInclude then subscope.specials.require = compiler["require-include"] - else end for _, val in parser.parser(parser["string-stream"](src), path) do table.insert(forms, val) end for i = 1, #forms do - local subopts + local subopts = nil if (i == #forms) then subopts = {tail = true} else @@ -2205,21 +2417,21 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct end local function include_path(ast, opts, path, mod, fennel_3f) utils.root.scope.includes[mod] = "fnl/loading" - local src + local src = nil do local f = assert(io.open(path)) - local function close_handlers_8_auto(ok_9_auto, ...) + local function close_handlers_10_(ok_11_, ...) f:close() - if ok_9_auto then + if ok_11_ then return ... else return error(..., 0) end end - local function _619_() + local function _684_() return assert(f:read("*all")):gsub("[\13\n]*$", "") end - src = close_handlers_8_auto(_G.xpcall(_619_, (package.loaded.fennel or debug).traceback)) + src = close_handlers_10_(_G.xpcall(_684_, (package.loaded.fennel or debug).traceback)) end local ret = utils.expr(("require(\"" .. mod .. "\")"), "statement") local target = ("package.preload[%q]"):format(mod) @@ -2243,23 +2455,19 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct if (utils.root.scope.includes[mod] == "fnl/loading") then compiler.assert(fallback, "circular include detected", ast) return fallback(modexpr) - else - return nil end end SPECIALS.include = function(ast, scope, parent, opts) compiler.assert((#ast == 2), "expected one argument", ast) - local modexpr + local modexpr = nil do - local _622_, _623_ = pcall(resolve_module_name, ast, scope, parent, opts) - if ((_622_ == true) and (nil ~= _623_)) then - local modname = _623_ + local _687_0, _688_0 = pcall(resolve_module_name, ast, scope, parent, opts) + if ((_687_0 == true) and (nil ~= _688_0)) then + local modname = _688_0 modexpr = utils.expr(string.format("%q", modname), "literal") - elseif true then - local _ = _622_ - modexpr = (compiler.compile1(ast[2], scope, parent, {nval = 1}))[1] else - modexpr = nil + local _ = _687_0 + modexpr = compiler.compile1(ast[2], scope, parent, {nval = 1})[1] end end if ((modexpr.type ~= "literal") or ((modexpr[1]):byte() ~= 34)) then @@ -2271,17 +2479,17 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct else local mod = load_code(("return " .. modexpr[1]))() local oldmod = utils.root.options["module-name"] - local _ + local _ = nil utils.root.options["module-name"] = mod _ = nil - local res - local function _627_() - local _626_ = search_module(mod) - if (nil ~= _626_) then - local fennel_path = _626_ + local res = nil + local function _692_() + local _691_0 = search_module(mod) + if (nil ~= _691_0) then + local fennel_path = _691_0 return include_path(ast, opts, fennel_path, mod, true) - elseif true then - local _0 = _626_ + else + local _0 = _691_0 local lua_path = search_module(mod, package.path) if lua_path then return include_path(ast, opts, lua_path, mod, false) @@ -2290,11 +2498,9 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct else return compiler.assert(false, ("module not found " .. mod), ast) end - else - return nil end end - res = ((utils["member?"](mod, (utils.root.options.skipInclude or {})) and opts.fallback(modexpr, true)) or include_circular_fallback(mod, modexpr, opts.fallback, ast) or utils.root.scope.includes[mod] or _627_()) + res = ((utils["member?"](mod, (utils.root.options.skipInclude or {})) and opts.fallback(modexpr, true)) or include_circular_fallback(mod, modexpr, opts.fallback, ast) or utils.root.scope.includes[mod] or _692_()) utils.root.options["module-name"] = oldmod return res end @@ -2305,41 +2511,90 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct local opts = utils.copy(utils.root.options) opts.scope = compiler["make-scope"](compiler.scopes.compiler) opts.allowedGlobals = current_global_names(env) - return assert(load_code(compiler.compile(ast, opts), wrap_env(env)), opts["module-name"], ast.filename)() + return assert(load_code(compiler.compile(ast, opts), wrap_env(env)))(opts["module-name"], ast.filename) end SPECIALS.macros = function(ast, scope, parent) - compiler.assert(((#ast == 2) and utils["table?"](ast[2])), "Expected one table argument", ast) - return add_macros(eval_compiler_2a(ast[2], scope, parent), ast, scope, parent) + compiler.assert((#ast == 2), "Expected one table argument", ast) + local macro_tbl = eval_compiler_2a(ast[2], scope, parent) + compiler.assert(utils["table?"](macro_tbl), "Expected one table argument", ast) + return add_macros(macro_tbl, ast, scope) end doc_special("macros", {"{:macro-name-1 (fn [...] ...) ... :macro-name-N macro-body-N}"}, "Define all functions in the given table as macros local to the current scope.") + SPECIALS["tail!"] = function(ast, scope, parent, opts) + compiler.assert((#ast == 2), "Expected one argument", ast) + local call = utils["list?"](compiler.macroexpand(ast[2], scope)) + local callee = tostring((call and utils["sym?"](call[1]))) + compiler.assert((call and not scope.specials[callee]), "Expected a function call as argument", ast) + compiler.assert(opts.tail, "Must be in tail position", ast) + return compiler.compile1(call, scope, parent, opts) + end + doc_special("tail!", {"body"}, "Assert that the body being called is in tail position.") + SPECIALS["pick-values"] = function(ast, scope, parent) + local n = ast[2] + local vals = utils.list(utils.sym("values"), unpack(ast, 3)) + compiler.assert((("number" == type(n)) and (0 <= n) and (n == math.floor(n))), ("Expected n to be an integer >= 0, got " .. tostring(n))) + if (1 == n) then + local _696_ = compiler.compile1(vals, scope, parent, {nval = 1}) + local _697_ = _696_[1] + local expr = _697_[1] + return {("(" .. expr .. ")")} + elseif (0 == n) then + for i = 3, #ast do + compiler["keep-side-effects"](compiler.compile1(ast[i], scope, parent, {nval = 0}), parent, nil, ast[i]) + end + return {} + else + local syms = nil + do + local tbl_17_ = utils.list() + local i_18_ = #tbl_17_ + for _ = 1, n do + local val_19_ = utils.sym(compiler.gensym(scope, "pv")) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end + end + syms = tbl_17_ + end + compiler.destructure(syms, vals, ast, scope, parent, {declaration = true, nomulti = true, noundef = true, symtype = "pv"}) + return syms + end + end + doc_special("pick-values", {"n", "..."}, "Evaluate to exactly n values.\n\nFor example,\n (pick-values 2 ...)\nexpands to\n (let [(_0_ _1_) ...]\n (values _0_ _1_))") SPECIALS["eval-compiler"] = function(ast, scope, parent) local old_first = ast[1] ast[1] = utils.sym("do") local val = eval_compiler_2a(ast, scope, parent) - do end (ast)[1] = old_first + ast[1] = old_first return val end doc_special("eval-compiler", {"..."}, "Evaluate the body at compile-time. Use the macro system instead if possible.", true) - return {doc = doc_2a, ["current-global-names"] = current_global_names, ["load-code"] = load_code, ["macro-loaded"] = macro_loaded, ["macro-searchers"] = macro_searchers, ["make-compiler-env"] = make_compiler_env, ["search-module"] = search_module, ["make-searcher"] = make_searcher, ["wrap-env"] = wrap_env} + SPECIALS.unquote = function(ast) + return compiler.assert(false, "tried to use unquote outside quote", ast) + end + doc_special("unquote", {"..."}, "Evaluate the argument even if it's in a quoted form.") + return {["current-global-names"] = current_global_names, ["get-function-metadata"] = get_function_metadata, ["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") local parser = require("fennel.parser") local friend = require("fennel.friend") + local view = require("fennel.view") local unpack = (table.unpack or _G.unpack) - local scopes = {} + local scopes = {compiler = nil, global = nil, macro = nil} local function make_scope(_3fparent) local parent = (_3fparent or scopes.global) - local _268_ + local _275_ if parent then - _268_ = ((parent.depth or 0) + 1) + _275_ = ((parent.depth or 0) + 1) else - _268_ = 0 + _275_ = 0 end - return {includes = setmetatable({}, {__index = (parent and parent.includes)}), macros = setmetatable({}, {__index = (parent and parent.macros)}), manglings = setmetatable({}, {__index = (parent and parent.manglings)}), specials = setmetatable({}, {__index = (parent and parent.specials)}), symmeta = setmetatable({}, {__index = (parent and parent.symmeta)}), unmanglings = setmetatable({}, {__index = (parent and parent.unmanglings)}), gensyms = setmetatable({}, {__index = (parent and parent.gensyms)}), autogensyms = setmetatable({}, {__index = (parent and parent.autogensyms)}), vararg = (parent and parent.vararg), depth = _268_, hashfn = (parent and parent.hashfn), refedglobals = {}, parent = parent} + return {["gensym-base"] = setmetatable({}, {__index = (parent and parent["gensym-base"])}), autogensyms = setmetatable({}, {__index = (parent and parent.autogensyms)}), depth = _275_, gensyms = setmetatable({}, {__index = (parent and parent.gensyms)}), hashfn = (parent and parent.hashfn), includes = setmetatable({}, {__index = (parent and parent.includes)}), macros = setmetatable({}, {__index = (parent and parent.macros)}), manglings = setmetatable({}, {__index = (parent and parent.manglings)}), parent = parent, refedglobals = {}, specials = setmetatable({}, {__index = (parent and parent.specials)}), symmeta = setmetatable({}, {__index = (parent and parent.symmeta)}), unmanglings = setmetatable({}, {__index = (parent and parent.unmanglings)}), vararg = (parent and parent.vararg)} end local function assert_msg(ast, msg) - local ast_tbl + local ast_tbl = nil if ("table" == type(ast)) then ast_tbl = ast else @@ -2350,15 +2605,15 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local line = ((m and m.line) or ast_tbl.line or "?") local col = ((m and m.col) or ast_tbl.col or "?") local target = tostring((utils["sym?"](ast_tbl[1]) or ast_tbl[1] or "()")) - return string.format("%s:%s:%s Compile error in '%s': %s", filename, line, col, target, msg) + return string.format("%s:%s:%s: Compile error in '%s': %s", filename, line, col, target, msg) end local function assert_compile(condition, msg, ast, _3ffallback_ast) if not condition then - local _let_271_ = (utils.root.options or {}) - local source = _let_271_["source"] - local unfriendly = _let_271_["unfriendly"] - local error_pinpoint = _let_271_["error-pinpoint"] - local ast0 + local _278_ = (utils.root.options or {}) + local error_pinpoint = _278_["error-pinpoint"] + local source = _278_["source"] + local unfriendly = _278_["unfriendly"] + local ast0 = nil if next(utils["ast-source"](ast)) then ast0 = ast else @@ -2366,14 +2621,12 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end if (nil == utils.hook("assert-compile", condition, msg, ast0, utils.root.reset)) then utils.root.reset() - if (unfriendly or not friend or not _G.io or not _G.io.read) then + if unfriendly then error(assert_msg(ast0, msg), 0) else friend["assert-compile"](condition, msg, ast0, source, {["error-pinpoint"] = error_pinpoint}) end - else end - else end return condition end @@ -2381,76 +2634,62 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct scopes.global.vararg = true scopes.compiler = make_scope(scopes.global) scopes.macro = scopes.global - local serialize_subst = {["\7"] = "\\a", ["\8"] = "\\b", ["\9"] = "\\t", ["\n"] = "n", ["\11"] = "\\v", ["\12"] = "\\f"} local function serialize_string(str) - local function _276_(_241) + local function _283_(_241) return ("\\" .. _241:byte()) end - return string.gsub(string.gsub(string.format("%q", str), ".", serialize_subst), "[\128-\255]", _276_) + return string.gsub(string.gsub(string.gsub(string.format("%q", str), "\\\n", "\\n"), "\\9", "\\t"), "[\128-\255]", _283_) end local function global_mangling(str) if utils["valid-lua-identifier?"](str) then return str else - local function _277_(_241) + local function _284_(_241) return string.format("_%02x", _241:byte()) end - return ("__fnl_global__" .. str:gsub("[^%w]", _277_)) + return ("__fnl_global__" .. str:gsub("[^%w]", _284_)) end end local function global_unmangling(identifier) - local _279_ = string.match(identifier, "^__fnl_global__(.*)$") - if (nil ~= _279_) then - local rest = _279_ - local _280_ - local function _281_(_241) + local _286_0 = string.match(identifier, "^__fnl_global__(.*)$") + if (nil ~= _286_0) then + local rest = _286_0 + local _287_0 = nil + local function _288_(_241) return string.char(tonumber(_241:sub(2), 16)) end - _280_ = string.gsub(rest, "_[%da-f][%da-f]", _281_) - return _280_ - elseif true then - local _ = _279_ - return identifier + _287_0 = string.gsub(rest, "_[%da-f][%da-f]", _288_) + return _287_0 else - return nil + local _ = _286_0 + return identifier end end - local allowed_globals = nil local function global_allowed_3f(name) - return (not allowed_globals or utils["member?"](name, allowed_globals)) + local allowed = nil + do + local _290_0 = utils.root.options + if (nil ~= _290_0) then + _290_0 = _290_0.allowedGlobals + end + allowed = _290_0 + end + return (not allowed or utils["member?"](name, allowed)) end local function unique_mangling(original, mangling, scope, append) - if (scope.unmanglings[mangling] and not scope.gensyms[mangling]) then + if scope.unmanglings[mangling] then return unique_mangling(original, (original .. append), scope, (append + 1)) else return mangling end end - local function local_mangling(str, scope, ast, _3ftemp_manglings) - assert_compile(not utils["multi-sym?"](str), ("unexpected multi symbol " .. str), ast) - local raw - if ((utils["lua-keywords"])[str] or str:match("^%d")) then - raw = ("_" .. str) - else - raw = str - end - local mangling - local function _285_(_241) - return string.format("_%02x", _241:byte()) - end - mangling = string.gsub(string.gsub(raw, "-", "_"), "[^%w_]", _285_) - local unique = unique_mangling(mangling, mangling, scope, 0) - do end (scope.unmanglings)[unique] = str - do - local manglings = (_3ftemp_manglings or scope.manglings) - do end (manglings)[str] = unique - end - return unique - end - local function apply_manglings(scope, new_manglings, ast) - for raw, mangled in pairs(new_manglings) do + local function apply_deferred_scope_changes(scope, deferred_scope_changes, ast) + for raw, mangled in pairs(deferred_scope_changes.manglings) do assert_compile(not scope.refedglobals[mangled], ("use of global " .. raw .. " is aliased by a local"), ast) - do end (scope.manglings)[raw] = mangled + scope.manglings[raw] = mangled + end + for raw, symmeta in pairs(deferred_scope_changes.symmeta) do + scope.symmeta[raw] = symmeta end return nil end @@ -2469,17 +2708,23 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end return ret end - local function next_append() - utils.root.scope["gensym-append"] = ((utils.root.scope["gensym-append"] or 0) + 1) - return ("_" .. utils.root.scope["gensym-append"] .. "_") + local function root_scope(scope) + return ((utils.root and utils.root.scope) or (scope.parent and root_scope(scope.parent)) or scope) + end + local function next_append(root_scope_2a) + root_scope_2a["gensym-append"] = ((root_scope_2a["gensym-append"] or 0) + 1) + return ("_" .. root_scope_2a["gensym-append"] .. "_") end local function gensym(scope, _3fbase, _3fsuffix) - local mangling = ((_3fbase or "") .. next_append() .. (_3fsuffix or "")) + local root_scope_2a = root_scope(scope) + local mangling = ((_3fbase or "") .. next_append(root_scope_2a) .. (_3fsuffix or "")) while scope.unmanglings[mangling] do - mangling = ((_3fbase or "") .. next_append() .. (_3fsuffix or "")) + mangling = ((_3fbase or "") .. next_append(root_scope_2a) .. (_3fsuffix or "")) end - scope.unmanglings[mangling] = (_3fbase or true) - do end (scope.gensyms)[mangling] = true + if (_3fbase and (0 < #_3fbase)) then + scope["gensym-base"][mangling] = _3fbase + end + scope.gensyms[mangling] = true return mangling end local function combine_auto_gensym(parts, first) @@ -2491,44 +2736,58 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct return table.concat(parts, ".") end local function autogensym(base, scope) - local _288_ = utils["multi-sym?"](base) - if (nil ~= _288_) then - local parts = _288_ + local _296_0 = utils["multi-sym?"](base) + if (nil ~= _296_0) then + local parts = _296_0 return combine_auto_gensym(parts, autogensym(parts[1], scope)) - elseif true then - local _ = _288_ - local function _289_() - local mangling = gensym(scope, base:sub(1, ( - 2)), "auto") - do end (scope.autogensyms)[base] = mangling + else + local _ = _296_0 + local function _297_() + local mangling = gensym(scope, base:sub(1, -2), "auto") + scope.autogensyms[base] = mangling return mangling end - return (scope.autogensyms[base] or _289_()) - else - return nil + return (scope.autogensyms[base] or _297_()) end end local function check_binding_valid(symbol, scope, ast, _3fopts) local name = tostring(symbol) - local macro_3f + local macro_3f = nil do - local t_291_ = _3fopts - if (nil ~= t_291_) then - t_291_ = (t_291_)["macro?"] - else + local _299_0 = _3fopts + if (nil ~= _299_0) then + _299_0 = _299_0["macro?"] end - macro_3f = t_291_ + macro_3f = _299_0 end - assert_compile(not name:find("&"), "invalid character: &", symbol) + assert_compile(("&" ~= name:match("[&.:]")), "invalid character: &", symbol) assert_compile(not name:find("^%."), "invalid character: .", symbol) assert_compile(not (scope.specials[name] or (not macro_3f and scope.macros[name])), ("local %s was overshadowed by a special form or macro"):format(name), ast) return assert_compile(not utils["quoted?"](symbol), string.format("macro tried to bind %s without gensym", name), symbol) end - local function declare_local(symbol, meta, scope, ast, _3ftemp_manglings) + local function declare_local(symbol, scope, ast, _3fvar_3f, _3fdeferred_scope_changes) check_binding_valid(symbol, scope, ast) - local name = tostring(symbol) - assert_compile(not utils["multi-sym?"](name), ("unexpected multi symbol " .. name), ast) - do end (scope.symmeta)[name] = meta - return local_mangling(name, scope, ast, _3ftemp_manglings) + assert_compile(not utils["multi-sym?"](symbol), ("unexpected multi symbol " .. tostring(symbol)), ast) + local str = tostring(symbol) + local raw = nil + if (utils["lua-keyword?"](str) or str:match("^%d")) then + raw = ("_" .. str) + else + raw = str + end + local mangling = nil + local function _302_(_241) + return string.format("_%02x", _241:byte()) + end + mangling = string.gsub(string.gsub(raw, "-", "_"), "[^%w_]", _302_) + local unique = unique_mangling(mangling, mangling, scope, 0) + scope.unmanglings[unique] = (scope["gensym-base"][str] or str) + do + local target = (_3fdeferred_scope_changes or scope) + target.manglings[str] = unique + target.symmeta[str] = {symbol = symbol, var = _3fvar_3f} + end + return unique end local function hashfn_arg_name(name, multi_sym_parts, scope) if not scope.hashfn then @@ -2538,11 +2797,8 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct elseif multi_sym_parts then if (multi_sym_parts and (multi_sym_parts[1] == "$")) then multi_sym_parts[1] = "$1" - else end return table.concat(multi_sym_parts, ".") - else - return nil end end local function symbol_to_expression(symbol, scope, _3freference_3f) @@ -2555,14 +2811,20 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local local_3f = scope.manglings[parts[1]] if (local_3f and scope.symmeta[parts[1]]) then scope.symmeta[parts[1]]["used"] = true - else + symbol.referent = scope.symmeta[parts[1]].symbol end assert_compile(not scope.macros[parts[1]], "tried to reference a macro without calling it", symbol) assert_compile((not scope.specials[parts[1]] or ("require" == parts[1])), "tried to reference a special form without calling it", symbol) assert_compile((not _3freference_3f or local_3f or ("_ENV" == parts[1]) or global_allowed_3f(parts[1])), ("unknown identifier: " .. tostring(parts[1])), symbol) - if (allowed_globals and not local_3f and scope.parent) then + local function _307_() + local _306_0 = utils.root.options + if (nil ~= _306_0) then + _306_0 = _306_0.allowedGlobals + end + return _306_0 + end + if (_307_() and not local_3f and scope.parent) then scope.parent.refedglobals[parts[1]] = true - else end return utils.expr(combine_parts(parts, scope), etype) end @@ -2587,7 +2849,16 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end return new_chunk else - return utils.map(chunk, peephole) + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for _, x in ipairs(chunk) do + local val_19_ = peephole(x) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end + end + return tbl_17_ end end local function flatten_chunk_correlated(main_chunk, options) @@ -2597,14 +2868,12 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct out[last_line0] = ((out[last_line0] or "") .. " " .. chunk.leaf) else for _, subchunk in ipairs(chunk) do - if (subchunk.leaf or (0 < #subchunk)) then + if (subchunk.leaf or next(subchunk)) then local source = utils["ast-source"](subchunk.ast) if (file == source.filename) then last_line0 = math.max(last_line0, (source.line or 0)) - else end last_line0 = flatten(subchunk, out, last_line0, file) - else end end end @@ -2615,47 +2884,63 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct for i = 1, last do if (out[i] == nil) then out[i] = "" - else end end return table.concat(out, "\n") end local function flatten_chunk(file_sourcemap, chunk, tab, depth) if chunk.leaf then - local _let_303_ = utils["ast-source"](chunk.ast) - local filename = _let_303_["filename"] - local line = _let_303_["line"] - table.insert(file_sourcemap, {filename, line}) + local _317_ = utils["ast-source"](chunk.ast) + local endline = _317_["endline"] + local filename = _317_["filename"] + local line = _317_["line"] + if ("end" == chunk.leaf) then + table.insert(file_sourcemap, {filename, (endline or line)}) + else + table.insert(file_sourcemap, {filename, line}) + end return chunk.leaf else - local tab0 + local tab0 = nil do - local _304_ = tab - if (_304_ == true) then + local _319_0 = tab + if (_319_0 == true) then tab0 = " " - elseif (_304_ == false) then + elseif (_319_0 == false) then tab0 = "" - elseif (_304_ == tab) then - tab0 = tab - elseif (_304_ == nil) then + elseif (nil ~= _319_0) then + local tab1 = _319_0 + tab0 = tab1 + elseif (_319_0 == nil) then tab0 = "" else - tab0 = nil + tab0 = nil end end - local function parter(c) - if (c.leaf or (0 < #c)) then - local sub = flatten_chunk(file_sourcemap, c, tab0, (depth + 1)) - if (0 < depth) then - return (tab0 .. sub:gsub("\n", ("\n" .. tab0))) + local _321_ + do + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for _, c in ipairs(chunk) do + local val_19_ = nil + if (c.leaf or next(c)) then + local sub = flatten_chunk(file_sourcemap, c, tab0, (depth + 1)) + if (0 < depth) then + val_19_ = (tab0 .. sub:gsub("\n", ("\n" .. tab0))) + else + val_19_ = sub + end else - return sub + val_19_ = nil + end + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end - else - return nil end + _321_ = tbl_17_ end - return table.concat(utils.map(chunk, parter), "\n") + return table.concat(_321_, "\n") end end local sourcemap = {} @@ -2669,11 +2954,12 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end local function flatten(chunk, options) local chunk0 = peephole(chunk) + local indent = (options.indent or " ") if options.correlate then return flatten_chunk_correlated(chunk0, options), {} else local file_sourcemap = {} - local src = flatten_chunk(file_sourcemap, chunk0, options.indent, 0) + local src = flatten_chunk(file_sourcemap, chunk0, indent, 0) file_sourcemap.short_src = (options.filename or make_short_src((options.source or src))) if options.filename then file_sourcemap.key = ("@" .. options.filename) @@ -2685,24 +2971,25 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end end local function make_metadata() - local function _312_(self, tgt, key) + local function _329_(self, tgt, _3fkey) if self[tgt] then - return self[tgt][key] - else - return nil + if (nil ~= _3fkey) then + return self[tgt][_3fkey] + else + return self[tgt] + end end end - local function _314_(self, tgt, key, value) + local function _332_(self, tgt, key, value) self[tgt] = (self[tgt] or {}) - do end (self[tgt])[key] = value + self[tgt][key] = value return tgt end - local function _315_(self, tgt, ...) + local function _333_(self, tgt, ...) local kv_len = select("#", ...) local kvs = {...} if ((kv_len % 2) ~= 0) then error("metadata:setall() expected even number of k/v pairs") - else end self[tgt] = (self[tgt] or {}) for i = 1, kv_len, 2 do @@ -2710,27 +2997,38 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end return tgt end - return setmetatable({}, {__index = {get = _312_, set = _314_, setall = _315_}, __mode = "k"}) + return setmetatable({}, {__index = {get = _329_, set = _332_, setall = _333_}, __mode = "k"}) end local function exprs1(exprs) - return table.concat(utils.map(exprs, tostring), ", ") - end - local function keep_side_effects(exprs, chunk, start, ast) - local start0 = (start or 1) - for j = start0, #exprs do - local se = exprs[j] - if ((se.type == "expression") and (se[1] ~= "nil")) then - emit(chunk, string.format("do local _ = %s end", tostring(se)), ast) - elseif (se.type == "statement") then - local code = tostring(se) - local disambiguated + local _335_ + do + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for _, e in ipairs(exprs) do + local val_19_ = tostring(e) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end + end + _335_ = tbl_17_ + end + return table.concat(_335_, ", ") + end + local function keep_side_effects(exprs, chunk, _3fstart, ast) + for j = (_3fstart or 1), #exprs do + local subexp = exprs[j] + if ((subexp.type == "expression") and (subexp[1] ~= "nil")) then + emit(chunk, ("do local _ = %s end"):format(tostring(subexp)), ast) + elseif (subexp.type == "statement") then + local code = tostring(subexp) + local disambiguated = nil if (code:byte() == 40) then disambiguated = ("do end " .. code) else disambiguated = code end emit(chunk, disambiguated, ast) - else end end return nil @@ -2750,47 +3048,42 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct exprs[i] = utils.expr("nil", "literal") end end - else end - else end if opts.tail then emit(parent, string.format("return %s", exprs1(exprs)), ast) - else end if opts.target then local result = exprs1(exprs) - local function _323_() + local function _343_() if (result == "") then return "nil" else return result end end - emit(parent, string.format("%s = %s", opts.target, _323_()), ast) - else + emit(parent, string.format("%s = %s", opts.target, _343_()), ast) end if (opts.tail or opts.target) then return {returned = true} else - local _325_ = exprs - _325_["returned"] = true - return _325_ + exprs["returned"] = true + return exprs end end local function find_macro(ast, scope) - local macro_2a + local macro_2a = nil do - local _327_ = utils["sym?"](ast[1]) - if (_327_ ~= nil) then - local _328_ = tostring(_327_) - if (_328_ ~= nil) then - macro_2a = scope.macros[_328_] + local _346_0 = utils["sym?"](ast[1]) + if (_346_0 ~= nil) then + local _347_0 = tostring(_346_0) + if (_347_0 ~= nil) then + macro_2a = scope.macros[_347_0] else - macro_2a = _328_ + macro_2a = _347_0 end else - macro_2a = _327_ + macro_2a = _346_0 end end local multi_sym_parts = utils["multi-sym?"](ast[1]) @@ -2802,18 +3095,17 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct return macro_2a end end - local function propagate_trace_info(_332_, _index, node) - local _arg_333_ = _332_ - local filename = _arg_333_["filename"] - local line = _arg_333_["line"] - local bytestart = _arg_333_["bytestart"] - local byteend = _arg_333_["byteend"] + local function propagate_trace_info(_351_0, _index, node) + local _352_ = _351_0 + local byteend = _352_["byteend"] + local bytestart = _352_["bytestart"] + local filename = _352_["filename"] + local line = _352_["line"] do local src = utils["ast-source"](node) if (("table" == type(node)) and (filename ~= src.filename)) then src.filename, src.line, src["from-macro?"] = filename, line, true src.bytestart, src.byteend = bytestart, byteend - else end end return ("table" == type(node)) @@ -2821,22 +3113,14 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local function quote_literal_nils(index, node, parent) if (parent and utils["list?"](parent)) then for i = 1, utils.maxn(parent) do - local _335_ = parent[i] - if (_335_ == nil) then + local _354_0 = parent[i] + if (_354_0 == nil) then parent[i] = utils.sym("nil") - else end end - else end return index, node, parent end - local function comp(f, g) - local function _338_(...) - return f(g(...)) - end - return _338_ - end local function built_in_3f(m) local found_3f = false for _, f in pairs(scopes.global.macros) do @@ -2846,64 +3130,58 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct return found_3f end local function macroexpand_2a(ast, scope, _3fonce) - local _339_ + local _357_0 = nil if utils["list?"](ast) then - _339_ = find_macro(ast, scope) + _357_0 = find_macro(ast, scope) else - _339_ = nil + _357_0 = nil end - if (_339_ == false) then + if (_357_0 == false) then return ast - elseif (nil ~= _339_) then - local macro_2a = _339_ + elseif (nil ~= _357_0) then + local macro_2a = _357_0 local old_scope = scopes.macro - local _ + local _ = nil scopes.macro = scope _ = nil local ok, transformed = nil, nil - local function _341_() + local function _359_() return macro_2a(unpack(ast, 2)) end - local function _342_() + local function _360_() if built_in_3f(macro_2a) then return tostring else return debug.traceback end end - ok, transformed = xpcall(_341_, _342_()) - local _344_ - do - local _343_ = ast - local function _345_(...) - return propagate_trace_info(_343_, ...) - end - _344_ = _345_ + ok, transformed = xpcall(_359_, _360_()) + local function _361_(...) + return propagate_trace_info(ast, quote_literal_nils(...)) end - utils["walk-tree"](transformed, comp(_344_, quote_literal_nils)) + utils["walk-tree"](transformed, _361_) scopes.macro = old_scope assert_compile(ok, transformed, ast) + utils.hook("macroexpand", ast, transformed, scope) if (_3fonce or not transformed) then return transformed else return macroexpand_2a(transformed, scope) end - elseif true then - local _ = _339_ - return ast else - return nil + local _ = _357_0 + return ast end end local function compile_special(ast, scope, parent, opts, special) local exprs = (special(ast, scope, parent, opts) or utils.expr("nil", "literal")) - local exprs0 + local exprs0 = nil if ("table" ~= type(exprs)) then exprs0 = utils.expr(exprs, "expression") else exprs0 = exprs end - local exprs2 + local exprs2 = nil if utils["expr?"](exprs0) then exprs2 = {exprs0} else @@ -2917,19 +3195,30 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct return exprs2 end end + local function callable_3f(_367_0, ctype, callee) + local _368_ = _367_0 + local call_ast = _368_[1] + if ("literal" == ctype) then + return ("\"" == string.sub(callee, 1, 1)) + else + return (utils["sym?"](call_ast) or utils["list?"](call_ast)) + end + end local function compile_function_call(ast, scope, parent, opts, compile1, len) + local _370_ = compile1(ast[1], scope, parent, {nval = 1})[1] + local callee = _370_[1] + local ctype = _370_["type"] local fargs = {} - local fcallee = (compile1(ast[1], scope, parent, {nval = 1}))[1] - assert_compile((utils["sym?"](ast[1]) or utils["list?"](ast[1]) or ("string" == type(ast[1]))), ("cannot call literal value " .. tostring(ast[1])), ast) + assert_compile(callable_3f(ast, ctype, callee), ("cannot call literal value " .. tostring(ast[1])), ast) for i = 2, len do - local subexprs - local _351_ + local subexprs = nil + local _371_ if (i ~= len) then - _351_ = 1 + _371_ = 1 else - _351_ = nil + _371_ = nil end - subexprs = compile1(ast[i], scope, parent, {nval = _351_}) + subexprs = compile1(ast[i], scope, parent, {nval = _371_}) table.insert(fargs, subexprs[1]) if (i == len) then for j = 2, #subexprs do @@ -2939,13 +3228,13 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct keep_side_effects(subexprs, parent, 2, ast[i]) end end - local pat - if ("string" == type(ast[1])) then + local pat = nil + if ("literal" == ctype) then pat = "(%s)(%s)" else pat = "%s(%s)" end - local call = string.format(pat, tostring(fcallee), exprs1(fargs)) + local call = string.format(pat, tostring(callee), exprs1(fargs)) return handle_compile_opts({utils.expr(call, "statement")}, parent, opts, ast) end local function compile_call(ast, scope, parent, opts, compile1) @@ -2967,19 +3256,19 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end end local function compile_varg(ast, scope, parent, opts) - local _356_ + local _376_ if scope.hashfn then - _356_ = "use $... in hashfn" + _376_ = "use $... in hashfn" else - _356_ = "unexpected vararg" + _376_ = "unexpected vararg" end - assert_compile(scope.vararg, _356_, ast) + assert_compile(scope.vararg, _376_, ast) return handle_compile_opts({utils.expr("...", "varg")}, parent, opts, ast) end local function compile_sym(ast, scope, parent, opts) local multi_sym_parts = utils["multi-sym?"](ast) assert_compile(not (multi_sym_parts and multi_sym_parts["multi-sym-method-call"]), "multisym method calls may only be in call position", ast) - local e + local e = nil if (ast[1] == "nil") then e = utils.expr("nil", "literal") else @@ -2987,74 +3276,85 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end return handle_compile_opts({e}, parent, opts, ast) end - local function serialize_number(n) - local _359_ = string.gsub(tostring(n), ",", ".") - return _359_ + local view_opts = nil + do + local nan = tostring((0 / 0)) + local _379_ + if (45 == nan:byte()) then + _379_ = "(0/0)" + else + _379_ = "(- (0/0))" + end + local _381_ + if (45 == nan:byte()) then + _381_ = "(- (0/0))" + else + _381_ = "(0/0)" + end + view_opts = {["negative-infinity"] = "(-1/0)", ["negative-nan"] = _379_, infinity = "(1/0)", nan = _381_} end local function compile_scalar(ast, _scope, parent, opts) - local serialize + local compiled = nil do - local _360_ = type(ast) - if (_360_ == "nil") then - serialize = tostring - elseif (_360_ == "boolean") then - serialize = tostring - elseif (_360_ == "string") then - serialize = serialize_string - elseif (_360_ == "number") then - serialize = serialize_number + local _383_0 = type(ast) + if (_383_0 == "nil") then + compiled = "nil" + elseif (_383_0 == "boolean") then + compiled = tostring(ast) + elseif (_383_0 == "string") then + compiled = serialize_string(ast) + elseif (_383_0 == "number") then + compiled = view(ast, view_opts) else - serialize = nil + compiled = nil end end - return handle_compile_opts({utils.expr(serialize(ast), "literal")}, parent, opts) + return handle_compile_opts({utils.expr(compiled, "literal")}, parent, opts) end local function compile_table(ast, scope, parent, opts, compile1) local function escape_key(k) if ((type(k) == "string") and utils["valid-lua-identifier?"](k)) then return k else - local _let_362_ = compile1(k, scope, parent, {nval = 1}) - local compiled = _let_362_[1] + local _385_ = compile1(k, scope, parent, {nval = 1}) + local compiled = _385_[1] return ("[" .. tostring(compiled) .. "]") end end local keys = {} - local buffer + local buffer = nil do - local tbl_16_auto = {} - local i_17_auto = #tbl_16_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ for i, elem in ipairs(ast) do - local val_18_auto + local val_19_ = nil do local nval = ((nil ~= ast[(i + 1)]) and 1) - do end (keys)[i] = true - val_18_auto = exprs1(compile1(elem, scope, parent, {nval = nval})) + keys[i] = true + val_19_ = exprs1(compile1(elem, scope, parent, {nval = nval})) end - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - buffer = tbl_16_auto + buffer = tbl_17_ end do - local tbl_16_auto = buffer - local i_17_auto = #tbl_16_auto - for k, v in utils.stablepairs(ast) do - local val_18_auto + local tbl_17_ = buffer + local i_18_ = #tbl_17_ + for k in utils.stablepairs(ast) do + local val_19_ = nil if not keys[k] then - local _let_365_ = compile1(ast[k], scope, parent, {nval = 1}) - local v0 = _let_365_[1] - val_18_auto = string.format("%s = %s", escape_key(k), tostring(v0)) + local _388_ = compile1(ast[k], scope, parent, {nval = 1}) + local v = _388_[1] + val_19_ = string.format("%s = %s", escape_key(k), tostring(v)) else - val_18_auto = nil + val_19_ = nil end - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end end @@ -3079,58 +3379,82 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end local function destructure(to, from, ast, scope, parent, opts) local opts0 = (opts or {}) - local _let_369_ = opts0 - local isvar = _let_369_["isvar"] - local declaration = _let_369_["declaration"] - local forceglobal = _let_369_["forceglobal"] - local forceset = _let_369_["forceset"] - local symtype = _let_369_["symtype"] + local _392_ = opts0 + local declaration = _392_["declaration"] + local forceglobal = _392_["forceglobal"] + local forceset = _392_["forceset"] + local isvar = _392_["isvar"] + local symtype = _392_["symtype"] local symtype0 = ("_" .. (symtype or "dst")) - local setter + local setter = nil if declaration then setter = "local %s = %s" else setter = "%s = %s" end - local new_manglings = {} - local function getname(symbol, up1) + local deferred_scope_changes = {manglings = {}, symmeta = {}} + local function getname(symbol, ast0) local raw = symbol[1] - assert_compile(not (opts0.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), ast0) if declaration then - return declare_local(symbol, nil, scope, symbol, new_manglings) + return declare_local(symbol, scope, symbol, isvar, deferred_scope_changes) else local parts = (utils["multi-sym?"](raw) or {raw}) - local meta = scope.symmeta[parts[1]] + local _394_ = parts + local first = _394_[1] + local meta = scope.symmeta[first] assert_compile(not raw:find(":"), "cannot set method sym", symbol) 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) - else end - assert_compile((meta or not opts0.noundef or global_allowed_3f(parts[1])), ("expected local " .. parts[1]), symbol) + assert_compile((meta or not opts0.noundef or (scope.hashfn and ("$" == first)) or global_allowed_3f(first)), ("expected local " .. first), symbol) if forceglobal then assert_compile(not scope.symmeta[scope.unmanglings[raw]], ("global " .. raw .. " conflicts with local"), symbol) - do end (scope.manglings)[raw] = global_mangling(raw) - do end (scope.unmanglings)[global_mangling(raw)] = raw - if allowed_globals then - table.insert(allowed_globals, raw) - else + scope.manglings[raw] = global_mangling(raw) + scope.unmanglings[global_mangling(raw)] = raw + local _397_ + do + local _396_0 = utils.root.options + if (nil ~= _396_0) then + _396_0 = _396_0.allowedGlobals + end + _397_ = _396_0 + end + if _397_ then + local _400_ + do + local _399_0 = utils.root.options + if (nil ~= _399_0) then + _399_0 = _399_0.allowedGlobals + end + _400_ = _399_0 + end + table.insert(_400_, raw) end - else end return symbol_to_expression(symbol, scope)[1] end end local function compile_top_target(lvalues) - local inits - local function _375_(_241) - if scope.manglings[_241] then - return _241 - else - return "nil" + local inits = nil + do + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for _, l in ipairs(lvalues) do + local val_19_ = nil + if scope.manglings[l] then + val_19_ = l + else + val_19_ = "nil" + end + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end end + inits = tbl_17_ end - inits = utils.map(lvalues, _375_) local init = table.concat(inits, ", ") local lvalue = table.concat(lvalues, ", ") local plast = parent[#parent] @@ -3140,7 +3464,6 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct for pi = plen, #parent do if (parent[pi] == plast) then plen = pi - else end end if ((#parent == (plen + 1)) and parent[#parent].leaf) then @@ -3150,7 +3473,6 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct else table.insert(parent, (plen + 1), {ast = ast, leaf = ("local " .. lvalue .. " = " .. init)}) end - else end return ret end @@ -3158,35 +3480,83 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local lname = getname(left, up1) check_binding_valid(left, scope, left) if top_3f then - compile_top_target({lname}) + return compile_top_target({lname}) else - emit(parent, setter:format(lname, exprs1(rightexprs)), left) + return emit(parent, setter:format(lname, exprs1(rightexprs)), left) end - if declaration then - scope.symmeta[tostring(left)] = {var = isvar} - return nil - else - return nil + end + local function dynamic_set_target(_411_0) + local _412_ = _411_0 + local _ = _412_[1] + local target = _412_[2] + local keys = {(table.unpack or unpack)(_412_, 3)} + assert_compile(utils["sym?"](target), "dynamic set needs symbol target", ast) + assert_compile(next(keys), "dynamic set needs at least one key", ast) + local keys0 = nil + do + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for _0, k in ipairs(keys) do + local val_19_ = tostring(compile1(k, scope, parent, {nval = 1})[1]) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end + end + keys0 = tbl_17_ + end + return string.format("%s[%s]", tostring(symbol_to_expression(target, scope, true)), table.concat(keys0, "][")) + end + local function destructure_values(left, rightexprs, up1, destructure1, top_3f) + local left_names, tables = {}, {} + for i, name in ipairs(left) do + if utils["sym?"](name) then + table.insert(left_names, getname(name, up1)) + elseif utils["call-of?"](name, ".") then + table.insert(left_names, dynamic_set_target(name)) + else + local symname = gensym(scope, symtype0) + table.insert(left_names, symname) + tables[i] = {name, utils.expr(symname, "sym")} + end + end + assert_compile(left[1], "must provide at least one value", left) + if top_3f then + compile_top_target(left_names) + elseif utils["expr?"](rightexprs) then + emit(parent, setter:format(table.concat(left_names, ","), exprs1(rightexprs)), left) + else + local names = table.concat(left_names, ",") + local target = nil + if declaration then + target = ("local " .. names) + else + target = names + end + emit(parent, compile1(rightexprs, scope, parent, {target = target}), left) end + for _, pair in utils.stablepairs(tables) do + destructure1(pair[1], {pair[2]}, left) + end + return nil end local unpack_fn = "function (t, k, e)\n local mt = getmetatable(t)\n if 'table' == type(mt) and mt.__fennelrest then\n return mt.__fennelrest(t, k)\n elseif e then\n local rest = {}\n for k, v in pairs(t) do\n if not e[k] then rest[k] = v end\n end\n return rest\n else\n return {(table.unpack or unpack)(t, k)}\n end\n end" local function destructure_kv_rest(s, v, left, excluded_keys, destructure1) - local exclude_str - local _382_ + local exclude_str = nil + local _417_ do - local tbl_16_auto = {} - local i_17_auto = #tbl_16_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ for _, k in ipairs(excluded_keys) do - local val_18_auto = string.format("[%s] = true", serialize_string(k)) - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + local val_19_ = string.format("[%s] = true", serialize_string(k)) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - _382_ = tbl_16_auto + _417_ = tbl_17_ end - exclude_str = table.concat(_382_, ", ") + exclude_str = table.concat(_417_, ", ") local subexpr = utils.expr(string.format(string.gsub(("(" .. unpack_fn .. ")(%s, %s, {%s})"), "\n%s*", " "), s, tostring(v), exclude_str), "expression") return destructure1(v, {subexpr}, left) end @@ -3194,184 +3564,181 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local unpack_str = ("(" .. unpack_fn .. ")(%s, %s)") local formatted = string.format(string.gsub(unpack_str, "\n%s*", " "), s, k) local subexpr = utils.expr(formatted, "expression") - assert_compile((utils["sequence?"](left) and (nil == left[(k + 2)])), "expected rest argument before last parameter", left) + local function _419_() + local next_symbol = left[(k + 2)] + return ((nil == next_symbol) or utils["sym?"](next_symbol, "&as")) + end + assert_compile((utils["sequence?"](left) and _419_()), "expected rest argument before last parameter", left) return destructure1(left[(k + 1)], {subexpr}, left) end - local function destructure_table(left, rightexprs, top_3f, destructure1) - local s = gensym(scope, symtype0) - local right - do - local _384_ - if top_3f then - _384_ = exprs1(compile1(from, scope, parent)) - else - _384_ = exprs1(rightexprs) - end - if (_384_ == "") then - right = "nil" - elseif (nil ~= _384_) then - local right0 = _384_ - right = right0 - else - right = nil + local function optimize_table_destructure_3f(left, right) + local function _420_() + local all = next(left) + for _, d in ipairs(left) do + if not all then break end + all = ((utils["sym?"](d) and not tostring(d):find("^&")) or (utils["list?"](d) and utils["sym?"](d[1], "."))) end + return all end - local excluded_keys = {} - emit(parent, string.format("local %s = %s", s, right), left) - for k, v in utils.stablepairs(left) do - if not (("number" == type(k)) and tostring(left[(k - 1)]):find("^&")) then - if (utils["sym?"](k) and (tostring(k) == "&")) then - destructure_kv_rest(s, v, left, excluded_keys, destructure1) - elseif (utils["sym?"](v) and (tostring(v) == "&")) then - destructure_rest(s, k, left, destructure1) - elseif (utils["sym?"](k) and (tostring(k) == "&as")) then - destructure_sym(v, {utils.expr(tostring(s))}, left) - elseif (utils["sequence?"](left) and (tostring(v) == "&as")) then - local _, next_sym, trailing = select(k, unpack(left)) - assert_compile((nil == trailing), "expected &as argument before last parameter", left) - destructure_sym(next_sym, {utils.expr(tostring(s))}, left) + return (utils["sequence?"](left) and utils["sequence?"](right) and _420_()) + end + local function destructure_table(left, rightexprs, top_3f, destructure1, up1) + if optimize_table_destructure_3f(left, rightexprs) then + return destructure_values(utils.list(unpack(left)), utils.list(utils.sym("values"), unpack(rightexprs)), up1, destructure1) + else + local right = nil + do + local _421_0 = nil + if top_3f then + _421_0 = exprs1(compile1(from, scope, parent)) else - local key - if (type(k) == "string") then - key = serialize_string(k) - else - key = k - end - local subexpr = utils.expr(string.format("%s[%s]", s, key), "expression") - if (type(k) == "string") then - table.insert(excluded_keys, k) - else - end - destructure1(v, {subexpr}, left) + _421_0 = exprs1(rightexprs) + end + if (_421_0 == "") then + right = "nil" + elseif (nil ~= _421_0) then + local right0 = _421_0 + right = right0 + else + right = nil end - else end - end - return nil - end - local function destructure_values(left, up1, top_3f, destructure1) - local left_names, tables = {}, {} - for i, name in ipairs(left) do - if utils["sym?"](name) then - table.insert(left_names, getname(name, up1)) + local s = nil + if utils["sym?"](rightexprs) then + s = right else - local symname = gensym(scope, symtype0) - table.insert(left_names, symname) - do end (tables)[i] = {name, utils.expr(symname, "sym")} - end - end - assert_compile(left[1], "must provide at least one value", left) - assert_compile(top_3f, "can't nest multi-value destructuring", left) - compile_top_target(left_names) - if declaration then - for _, sym in ipairs(left) do - if utils["sym?"](sym) then - scope.symmeta[tostring(sym)] = {var = isvar} - else + s = gensym(scope, symtype0) + end + local excluded_keys = {} + if not utils["sym?"](rightexprs) then + emit(parent, string.format("local %s = %s", s, right), left) + end + for k, v in utils.stablepairs(left) do + if not (("number" == type(k)) and tostring(left[(k - 1)]):find("^&")) then + if (utils["sym?"](k) and (tostring(k) == "&")) then + destructure_kv_rest(s, v, left, excluded_keys, destructure1) + elseif (utils["sym?"](v) and (tostring(v) == "&")) then + destructure_rest(s, k, left, destructure1) + elseif (utils["sym?"](k) and (tostring(k) == "&as")) then + destructure_sym(v, {utils.expr(tostring(s))}, left) + elseif (utils["sequence?"](left) and (tostring(v) == "&as")) then + local _, next_sym, trailing = select(k, unpack(left)) + assert_compile((nil == trailing), "expected &as argument before last parameter", left) + destructure_sym(next_sym, {utils.expr(tostring(s))}, left) + else + local key = nil + if (type(k) == "string") then + key = serialize_string(k) + else + key = k + end + local subexpr = utils.expr(("%s[%s]"):format(s, key), "expression") + if (type(k) == "string") then + table.insert(excluded_keys, k) + end + destructure1(v, subexpr, left) + end end end - else - end - for _, pair in utils.stablepairs(tables) do - destructure1(pair[1], {pair[2]}, left) + return nil end - return nil end local function destructure1(left, rightexprs, up1, top_3f) if (utils["sym?"](left) and (left[1] ~= "nil")) then destructure_sym(left, rightexprs, up1, top_3f) elseif utils["table?"](left) then - destructure_table(left, rightexprs, top_3f, destructure1) + destructure_table(left, rightexprs, top_3f, destructure1, up1) + elseif utils["call-of?"](left, ".") then + destructure_values({left}, rightexprs, up1, destructure1) elseif utils["list?"](left) then - destructure_values(left, up1, top_3f, destructure1) + assert_compile(top_3f, "can't nest multi-value destructuring", left) + destructure_values(left, rightexprs, up1, destructure1, true) else - assert_compile(false, string.format("unable to bind %s %s", type(left), tostring(left)), (((type((up1)[2]) == "table") and (up1)[2]) or up1)) - end - if top_3f then - return {returned = true} - else - return nil + assert_compile(false, string.format("unable to bind %s %s", type(left), tostring(left)), (((type(up1[2]) == "table") and up1[2]) or up1)) end + return (top_3f and {returned = true}) end - local ret = destructure1(to, nil, ast, true) + local ret = destructure1(to, from, ast, true) utils.hook("destructure", from, to, scope, opts0) - apply_manglings(scope, new_manglings, ast) + apply_deferred_scope_changes(scope, deferred_scope_changes, ast) return ret end local function require_include(ast, scope, parent, opts) opts.fallback = function(e, no_warn) - if (not no_warn and ("literal" == e.type)) then - utils.warn(("include module not found, falling back to require: %s"):format(tostring(e))) - else + if not no_warn then + utils.warn(("include module not found, falling back to require: %s"):format(tostring(e)), ast) end return utils.expr(string.format("require(%s)", tostring(e)), "statement") end return scopes.global.specials.include(ast, scope, parent, opts) end - local function compile_stream(strm, options) + local function compile_asts(asts, options) local opts = utils.copy(options) - local old_globals = allowed_globals local scope = (opts.scope or make_scope(scopes.global)) - local vals = {} local chunk = {} - do end (function(tgt, m, ...) return tgt[m](tgt, ...) end)(utils.root, "set-reset") - allowed_globals = opts.allowedGlobals - if (opts.indent == nil) then - opts.indent = " " - else - end if opts.requireAsInclude then scope.specials.require = require_include - else end + if opts.assertAsRepl then + scope.macros.assert = scope.macros["assert-repl"] + end + local _435_ = utils.root + _435_["set-reset"](_435_) utils.root.chunk, utils.root.scope, utils.root.options = chunk, scope, opts - for _, val in parser.parser(strm, opts.filename, opts) do - table.insert(vals, val) - end - for i = 1, #vals do - local exprs = compile1(vals[i], scope, chunk, {nval = (((i < #vals) and 0) or nil), tail = (i == #vals)}) - keep_side_effects(exprs, chunk, nil, vals[i]) - if (i == #vals) then - utils.hook("chunk", vals[i], scope) - else + for i = 1, #asts do + local exprs = compile1(asts[i], scope, chunk, {nval = (((i < #asts) and 0) or nil), tail = (i == #asts)}) + keep_side_effects(exprs, chunk, nil, asts[i]) + if (i == #asts) then + utils.hook("chunk", asts[i], scope) end end - allowed_globals = old_globals utils.root.reset() return flatten(chunk, opts) end - local function compile_string(str, _3fopts) + local function compile_stream(stream, _3fopts) local opts = (_3fopts or {}) - return compile_stream(parser["string-stream"](str, opts), opts) - end - local function compile(ast, opts) - local opts0 = utils.copy(opts) - local old_globals = allowed_globals - local chunk = {} - local scope = (opts0.scope or make_scope(scopes.global)) - do end (function(tgt, m, ...) return tgt[m](tgt, ...) end)(utils.root, "set-reset") - allowed_globals = opts0.allowedGlobals - if (opts0.indent == nil) then - opts0.indent = " " - else + local asts = nil + do + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for _, ast in parser.parser(stream, opts.filename, opts) do + local val_19_ = ast + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end + end + asts = tbl_17_ end - if opts0.requireAsInclude then - scope.specials.require = require_include + return compile_asts(asts, opts) + end + local function compile_string(str, _3fopts) + return compile_stream(parser["string-stream"](str, _3fopts), _3fopts) + end + local function compile(from, _3fopts) + local _438_0 = type(from) + if (_438_0 == "userdata") then + local function _439_() + local _440_0 = from:read(1) + if (nil ~= _440_0) then + return _440_0:byte() + else + return _440_0 + end + end + return compile_stream(_439_, _3fopts) + elseif (_438_0 == "function") then + return compile_stream(from, _3fopts) else + local _ = _438_0 + return compile_asts({from}, _3fopts) end - utils.root.chunk, utils.root.scope, utils.root.options = chunk, scope, opts0 - local exprs = compile1(ast, scope, chunk, {tail = true}) - keep_side_effects(exprs, chunk, nil, ast) - utils.hook("chunk", ast, scope) - allowed_globals = old_globals - utils.root.reset() - return flatten(chunk, opts0) end local function traceback_frame(info) if ((info.what == "C") and info.name) then - return string.format(" [C]: in function '%s'", info.name) + return string.format("\9[C]: in function '%s'", info.name) elseif (info.what == "C") then - return " [C]: in ?" + return "\9[C]: in ?" else local remap = sourcemap[info.source] if (remap and remap[info.currentline]) then @@ -3381,63 +3748,100 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct info.short_src = remap.short_src end info.currentline = (remap[info.currentline][2] or -1) - else end if (info.what == "Lua") then - local function _404_() + local function _445_() if info.name then return ("'" .. info.name .. "'") else return "?" end end - return string.format(" %s:%d: in function %s", info.short_src, info.currentline, _404_()) + return string.format("\9%s:%d: in function %s", info.short_src, info.currentline, _445_()) elseif (info.short_src == "(tail call)") then return " (tail call)" else - return string.format(" %s:%d: in main chunk", info.short_src, info.currentline) + return string.format("\9%s:%d: in main chunk", info.short_src, info.currentline) end end end + local lua_getinfo = debug.getinfo local function traceback(_3fmsg, _3fstart) - local msg = tostring((_3fmsg or "")) - if ((msg:find("^%g+:%d+:%d+ Compile error:.*") or msg:find("^%g+:%d+:%d+ Parse error:.*")) and not utils["debug-on?"]("trace")) then - return msg - else - local lines = {} - if (msg:find("^%g+:%d+:%d+ Compile error:") or msg:find("^%g+:%d+:%d+ Parse error:")) then - table.insert(lines, msg) - else - local newmsg = msg:gsub("^[^:]*:%d+:%s+", "runtime error: ") - table.insert(lines, newmsg) - end - table.insert(lines, "stack traceback:") - local done_3f, level = false, (_3fstart or 2) - while not done_3f do - do - local _408_ = debug.getinfo(level, "Sln") - if (_408_ == nil) then - done_3f = true - elseif (nil ~= _408_) then - local info = _408_ - table.insert(lines, traceback_frame(info)) - else + local _448_0 = type(_3fmsg) + if ((_448_0 == "nil") or (_448_0 == "string")) then + local msg = (_3fmsg or "") + if ((msg:find("^%g+:%d+:%d+ Compile error:.*") or msg:find("^%g+:%d+:%d+ Parse error:.*")) and not utils["debug-on?"]("trace")) then + return msg + else + local lines = {} + if (msg:find("^%g+:%d+:%d+ Compile error:") or msg:find("^%g+:%d+:%d+ Parse error:")) then + table.insert(lines, msg) + else + local newmsg = msg:gsub("^[^:]*:%d+:%s+", "runtime error: ") + table.insert(lines, newmsg) + end + table.insert(lines, "stack traceback:") + local done_3f, level = false, (_3fstart or 2) + while not done_3f do + do + local _450_0 = lua_getinfo(level, "Sln") + if (_450_0 == nil) then + done_3f = true + elseif (nil ~= _450_0) then + local info = _450_0 + table.insert(lines, traceback_frame(info)) + end end + level = (level + 1) end - level = (level + 1) + return table.concat(lines, "\n") end - return table.concat(lines, "\n") + else + local _ = _448_0 + return _3fmsg end end - local function entry_transform(fk, fv) - local function _411_(k, v) - if (type(k) == "number") then - return k, fv(v) - else - return fk(k), fv(v) + local function getinfo(thread_or_level, ...) + local thread_or_level0 = nil + if ("number" == type(thread_or_level)) then + thread_or_level0 = (1 + thread_or_level) + else + thread_or_level0 = thread_or_level + end + local info = lua_getinfo(thread_or_level0, ...) + local mapped = (info and sourcemap[info.source]) + if mapped then + for _, key in ipairs({"currentline", "linedefined", "lastlinedefined"}) do + local mapped_value = nil + do + local _455_0 = mapped + if (nil ~= _455_0) then + _455_0 = _455_0[info[key]] + end + if (nil ~= _455_0) then + _455_0 = _455_0[2] + end + mapped_value = _455_0 + end + if (info[key] and mapped_value) then + info[key] = mapped_value + end + end + if info.activelines then + local tbl_14_ = {} + for line in pairs(info.activelines) do + local k_15_, v_16_ = mapped[line][2], true + if ((k_15_ ~= nil) and (v_16_ ~= nil)) then + tbl_14_[k_15_] = v_16_ + end + end + info.activelines = tbl_14_ + end + if (info.what == "Lua") then + info.what = "Fennel" end end - return _411_ + return info end local function mixed_concat(t, joiner) local seen = {} @@ -3451,20 +3855,33 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct if not seen[k] then ret = (ret .. s .. "[" .. k .. "]" .. "=" .. v) s = joiner - else end end return ret end local function do_quote(form, scope, parent, runtime_3f) - local function q(x) - return do_quote(x, scope, parent, runtime_3f) + local function quote_all(form0, discard_non_numbers) + local tbl_14_ = {} + for k, v in utils.stablepairs(form0) do + local k_15_, v_16_ = nil, nil + if (type(k) == "number") then + k_15_, v_16_ = k, do_quote(v, scope, parent, runtime_3f) + elseif not discard_non_numbers then + k_15_, v_16_ = do_quote(k, scope, parent, runtime_3f), do_quote(v, scope, parent, runtime_3f) + else + k_15_, v_16_ = nil + end + if ((k_15_ ~= nil) and (v_16_ ~= nil)) then + tbl_14_[k_15_] = v_16_ + end + end + return tbl_14_ end if utils["varg?"](form) then assert_compile(not runtime_3f, "quoted ... may only be used at compile time", form) return "_VARARG" elseif utils["sym?"](form) then - local filename + local filename = nil if form.filename then filename = string.format("%q", form.filename) else @@ -3473,93 +3890,87 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local symstr = tostring(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', {filename=%s, line=%s})", autogensym(symstr, scope), filename, (form.line or "nil")) + return string.format("_G.sym('%s', {filename=%s, line=%s})", autogensym(symstr, scope), filename, (form.line or "nil")) else - return string.format("sym('%s', {quoted=true, filename=%s, line=%s})", symstr, filename, (form.line or "nil")) + return string.format("_G.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 (tostring(form[1]) == "unquote")) then - local payload = form[2] - local res = unpack(compile1(payload, scope, parent)) + elseif utils["call-of?"](form, "unquote") then + local res = unpack(compile1(form[2], scope, parent)) return res[1] elseif utils["list?"](form) then - local mapped - local function _416_() - return nil - end - mapped = utils.kvmap(form, entry_transform(_416_, q)) - local filename + local mapped = quote_all(form, true) + local filename = nil if form.filename then filename = string.format("%q", form.filename) else filename = "nil" 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, ", ")) + return string.format(("setmetatable({filename=%s, line=%s, bytestart=%s, %s}" .. ", getmetatable(_G.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 mapped = quote_all(form) local source = getmetatable(form) - local filename + local filename = nil if source.filename then filename = string.format("%q", source.filename) else filename = "nil" end - local _419_ + local _470_ if source then - _419_ = source.line + _470_ = source.line else - _419_ = "nil" + _470_ = "nil" end - return string.format("setmetatable({%s}, {filename=%s, line=%s, sequence=%s})", mixed_concat(mapped, ", "), filename, _419_, "(getmetatable(sequence()))['sequence']") + return string.format("setmetatable({%s}, {filename=%s, line=%s, sequence=%s})", mixed_concat(mapped, ", "), filename, _470_, "(getmetatable(_G.sequence()))['sequence']") elseif (type(form) == "table") then - local mapped = utils.kvmap(form, entry_transform(q, q)) + local mapped = quote_all(form) local source = getmetatable(form) - local filename + local filename = nil if source.filename then filename = string.format("%q", source.filename) else filename = "nil" end - local function _422_() + local function _473_() if source then return source.line else return "nil" end end - return string.format("setmetatable({%s}, {filename=%s, line=%s})", mixed_concat(mapped, ", "), filename, _422_()) + return string.format("setmetatable({%s}, {filename=%s, line=%s})", mixed_concat(mapped, ", "), filename, _473_()) elseif (type(form) == "string") then return serialize_string(form) else return tostring(form) end end - return {compile = compile, compile1 = compile1, ["compile-stream"] = compile_stream, ["compile-string"] = compile_string, ["check-binding-valid"] = check_binding_valid, emit = emit, destructure = destructure, ["require-include"] = require_include, autogensym = autogensym, gensym = gensym, ["do-quote"] = do_quote, ["global-mangling"] = global_mangling, ["global-unmangling"] = global_unmangling, ["apply-manglings"] = apply_manglings, macroexpand = macroexpand_2a, ["declare-local"] = declare_local, ["make-scope"] = make_scope, ["keep-side-effects"] = keep_side_effects, ["symbol-to-expression"] = symbol_to_expression, assert = assert_compile, scopes = scopes, traceback = traceback, metadata = make_metadata(), sourcemap = sourcemap} + return {["apply-deferred-scope-changes"] = apply_deferred_scope_changes, ["check-binding-valid"] = check_binding_valid, ["compile-stream"] = compile_stream, ["compile-string"] = compile_string, ["declare-local"] = declare_local, ["do-quote"] = do_quote, ["global-allowed?"] = global_allowed_3f, ["global-mangling"] = global_mangling, ["global-unmangling"] = global_unmangling, ["keep-side-effects"] = keep_side_effects, ["make-scope"] = make_scope, ["require-include"] = require_include, ["symbol-to-expression"] = symbol_to_expression, assert = assert_compile, autogensym = autogensym, compile = compile, compile1 = compile1, destructure = destructure, emit = emit, gensym = gensym, getinfo = getinfo, macroexpand = macroexpand_2a, metadata = make_metadata(), scopes = scopes, sourcemap = sourcemap, traceback = traceback} end package.preload["fennel.friend"] = package.preload["fennel.friend"] or function(...) local utils = require("fennel.utils") local utf8_ok_3f, utf8 = pcall(require, "utf8") - local suggestions = {["unexpected multi symbol (.*)"] = {"removing periods or colons from %s"}, ["use of global (.*) is aliased by a local"] = {"renaming local %s", "refer to the global using _G.%s instead of directly"}, ["local (.*) was overshadowed by a special form or macro"] = {"renaming local %s"}, ["global (.*) conflicts with local"] = {"renaming local %s"}, ["expected var (.*)"] = {"declaring %s using var instead of let/local", "introducing a new local instead of changing the value of %s"}, ["expected macros to be table"] = {"ensuring your macro definitions return a table"}, ["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"}, ["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"}, ["unknown identifier: (.*)"] = {"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"}, ["expected a function.* to call"] = {"removing the empty parentheses", "using square brackets if you want an empty table"}, ["cannot call literal value"] = {"checking for typos", "checking for a missing function name", "making sure to use prefix operators, not infix"}, ["unexpected vararg"] = {"putting \"...\" at the end of the fn parameters if the vararg was intended"}, ["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"}, ["unused local (.*)"] = {"renaming the local to _%s if it is meant to be unused", "fixing a typo so %s is used", "disabling the linter which checks for unused locals"}, ["expected parameters"] = {"adding function parameters as a list of identifiers in brackets"}, ["unable to bind (.*)"] = {"replacing the %s with an identifier"}, ["expected rest argument before last parameter"] = {"moving & to right before the final identifier when destructuring"}, ["expected vararg as last parameter"] = {"moving the \"...\" to the end of the parameter list"}, ["expected symbol for function parameter: (.*)"] = {"changing %s to an identifier instead of a literal value"}, ["could not compile value of type "] = {"debugging the macro you're calling to return a list or table"}, ["expected local"] = {"looking for a typo", "looking for a local which is used out of its scope"}, ["expected body expression"] = {"putting some code in the body of this form after the bindings"}, ["expected binding and iterator"] = {"making sure you haven't omitted a local name or iterator"}, ["expected binding sequence"] = {"placing a table here in square brackets containing identifiers to bind"}, ["expected even number of name/value bindings"] = {"finding where the identifier or value is missing"}, ["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"}, ["unexpected closing delimiter (.)"] = {"deleting %s", "adding matching opening delimiter earlier"}, ["mismatched closing delimiter (.), expected (.)"] = {"replacing %s with %s", "deleting %s", "adding matching opening delimiter earlier"}, ["expected even number of values in table literal"] = {"removing a key", "adding a value"}, ["expected whitespace before opening delimiter"] = {"adding whitespace"}, ["invalid character: (.)"] = {"deleting or replacing %s", "avoiding reserved characters like \", \\, ', ~, ;, @, `, and comma"}, ["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"}, ["can't start multisym segment with a digit"] = {"removing the digit", "adding a non-digit before the digit"}, ["malformed multisym"] = {"ensuring each period or colon is not followed by another period or colon"}, ["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"}, ["$ and $... in hashfn are mutually exclusive"] = {"modifying the hashfn so it only contains $... or $, $1, $2, $3, etc"}, ["tried to reference a macro without calling it"] = {"renaming the macro so as not to conflict with locals"}, ["tried to reference a special form without calling it"] = {"making sure to use prefix operators, not infix", "wrapping the special in a function if you need it to be first class"}, ["missing subject"] = {"adding an item to operate on"}, ["expected even number of pattern/body pairs"] = {"checking that every pattern has a body to go with it", "adding _ before the final body"}, ["expected at least one pattern/body pair"] = {"adding a pattern and a body to execute when the pattern matches"}, ["unexpected arguments"] = {"removing an argument", "checking for typos"}, ["unexpected iterator clause"] = {"removing an argument", "checking for typos"}} + local suggestions = {["$ and $... in hashfn are mutually exclusive"] = {"modifying the hashfn so it only contains $... or $, $1, $2, $3, etc"}, ["can't introduce (.*) here"] = {"declaring the local at the top-level"}, ["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", "making sure to use prefix operators, not infix"}, ["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 at least one pattern/body pair"] = {"adding a pattern and a body to execute when the pattern matches"}, ["expected binding and iterator"] = {"making sure you haven't omitted a local name or iterator"}, ["expected binding sequence"] = {"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 pattern/body pairs"] = {"checking that every pattern has a body to go with it", "adding _ before the final body"}, ["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 range to include start and stop"] = {"adding missing arguments"}, ["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"}, ["invalid 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"}, ["missing subject"] = {"adding an item to operate on"}, ["multisym method calls may only be in call position"] = {"using a period instead of a colon to reference a table's fields", "putting parens around this"}, ["tried to reference a macro without calling it"] = {"renaming the macro so as not to conflict with locals"}, ["tried to reference a special form without calling it"] = {"making sure to use prefix operators, not infix", "wrapping the special in a function if you need it to be first class"}, ["tried to use unquote outside quote"] = {"moving the form to inside a quoted form", "removing the comma"}, ["tried to use vararg with operator"] = {"accumulating over the operands"}, ["unable to bind (.*)"] = {"replacing the %s with an identifier"}, ["unexpected arguments"] = {"removing an argument", "checking for typos"}, ["unexpected closing delimiter (.)"] = {"deleting %s", "adding matching opening delimiter earlier"}, ["unexpected iterator clause"] = {"removing an argument", "checking for typos"}, ["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 identifier: (.*)"] = {"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 (.*)"] = {"renaming the local to _%s if it is meant to be unused", "fixing a typo so %s is used", "disabling the linter which checks for unused locals"}, ["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 s = nil for pat, sug in pairs(suggestions) do if s then break end local matches = {msg:match(pat)} - if (0 < #matches) then - local tbl_16_auto = {} - local i_17_auto = #tbl_16_auto + if next(matches) then + local tbl_17_ = {} + local i_18_ = #tbl_17_ for _, s0 in ipairs(sug) do - local val_18_auto = s0:format(unpack(matches)) - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + local val_19_ = s0:format(unpack(matches)) + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - s = tbl_16_auto + s = tbl_17_ else - s = nil + s = nil end end return s @@ -3572,26 +3983,26 @@ package.preload["fennel.friend"] = package.preload["fennel.friend"] or function( end return matcher() else - local f = assert(io.open(filename)) - local function close_handlers_8_auto(ok_9_auto, ...) + local f = assert(_G.io.open(filename)) + local function close_handlers_10_(ok_11_, ...) f:close() - if ok_9_auto then + if ok_11_ then return ... else return error(..., 0) end end - local function _185_() + local function _190_() for _ = 2, line do f:read() end return f:read() end - return close_handlers_8_auto(_G.xpcall(_185_, (package.loaded.fennel or debug).traceback)) + return close_handlers_10_(_G.xpcall(_190_, (package.loaded.fennel or debug).traceback)) end end local function sub(str, start, _end) - if ((_end < start) or (#str < start) or (#str < _end)) then + if ((_end < start) or (#str < start)) then return "" elseif utf8_ok_3f then return string.sub(str, utf8.offset(str, start), ((utf8.offset(str, (_end + 1)) or (utf8.len(str) + 1)) - 1)) @@ -3603,36 +4014,42 @@ package.preload["fennel.friend"] = package.preload["fennel.friend"] or function( if ((opts and (false == opts["error-pinpoint"])) or (os and os.getenv and os.getenv("NO_COLOR"))) then return codeline else - local _let_188_ = (opts or {}) - local error_pinpoint = _let_188_["error-pinpoint"] + local _193_ = (opts or {}) + local error_pinpoint = _193_["error-pinpoint"] local endcol = (_3fendcol or col) - local eol + local eol = nil if utf8_ok_3f then eol = utf8.len(codeline) else eol = string.len(codeline) end - local _let_190_ = (error_pinpoint or {"\27[7m", "\27[0m"}) - local open = _let_190_[1] - local close = _let_190_[2] + local _195_ = (error_pinpoint or {"\27[7m", "\27[0m"}) + local open = _195_[1] + local close = _195_[2] return (sub(codeline, 1, col) .. open .. sub(codeline, (col + 1), (endcol + 1)) .. close .. sub(codeline, (endcol + 2), eol)) end end - local function friendly_msg(msg, _192_, source, opts) - local _arg_193_ = _192_ - local filename = _arg_193_["filename"] - local line = _arg_193_["line"] - local col = _arg_193_["col"] - local endcol = _arg_193_["endcol"] + local function friendly_msg(msg, _197_0, source, opts) + local _198_ = _197_0 + local col = _198_["col"] + local endcol = _198_["endcol"] + local endline = _198_["endline"] + local filename = _198_["filename"] + local line = _198_["line"] local ok, codeline = pcall(read_line, filename, line, source) + local endcol0 = nil + if (ok and codeline and (line ~= endline)) then + endcol0 = #codeline + else + endcol0 = endcol + end local out = {msg, ""} if (ok and codeline) then if col then - table.insert(out, highlight_line(codeline, col, endcol, opts)) + table.insert(out, highlight_line(codeline, col, endcol0, opts)) else table.insert(out, codeline) end - else end for _, suggestion in ipairs((suggest(msg) or {})) do table.insert(out, ("* Try %s."):format(suggestion)) @@ -3641,17 +4058,16 @@ package.preload["fennel.friend"] = package.preload["fennel.friend"] or function( end local function assert_compile(condition, msg, ast, source, opts) if not condition then - local _let_196_ = utils["ast-source"](ast) - local filename = _let_196_["filename"] - local line = _let_196_["line"] - local col = _let_196_["col"] - error(friendly_msg(("%s:%s:%s Compile error: %s"):format((filename or "unknown"), (line or "?"), (col or "?"), msg), utils["ast-source"](ast), source, opts), 0) - else + local _202_ = utils["ast-source"](ast) + local col = _202_["col"] + local filename = _202_["filename"] + local line = _202_["line"] + error(friendly_msg(("%s:%s:%s: Compile error: %s"):format((filename or "unknown"), (line or "?"), (col or "?"), msg), utils["ast-source"](ast), source, opts), 0) end return condition end local function parse_error(msg, filename, line, col, source, opts) - return error(friendly_msg(("%s:%s:%s Parse error: %s"):format(filename, line, col, msg), {filename = filename, line = line, col = col}, source, opts), 0) + return error(friendly_msg(("%s:%s:%s: Parse error: %s"):format(filename, line, col, msg), {col = col, filename = filename, line = line}, source, opts), 0) end return {["assert-compile"] = assert_compile, ["parse-error"] = parse_error} end @@ -3661,58 +4077,53 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( local unpack = (table.unpack or _G.unpack) local function granulate(getchunk) local c, index, done_3f = "", 1, false - local function _198_(parser_state) + local function _204_(parser_state) if not done_3f then if (index <= #c) then local b = c:byte(index) index = (index + 1) return b else - local _199_ = getchunk(parser_state) - local function _200_() - local char = _199_ + local _205_0 = getchunk(parser_state) + local function _206_() + local char = _205_0 return (char ~= "") end - if ((nil ~= _199_) and _200_()) then - local char = _199_ + if ((nil ~= _205_0) and _206_()) then + local char = _205_0 c = char index = 2 return c:byte() - elseif true then - local _ = _199_ - done_3f = true - return nil else + local _ = _205_0 + done_3f = true return nil end end - else - return nil end end - local function _204_() + local function _210_() c = "" return nil end - return _198_, _204_ + return _204_, _210_ end local function string_stream(str, _3foptions) local str0 = str:gsub("^#!", ";;") if _3foptions then _3foptions.source = str0 - else end local index = 1 - local function _206_() + local function _212_() local r = str0:byte(index) index = (index + 1) return r end - return _206_ + return _212_ end - local delims = {[40] = 41, [41] = true, [91] = 93, [93] = true, [123] = 125, [125] = true} + local delims = {[123] = 125, [125] = true, [40] = 41, [41] = true, [91] = 93, [93] = true} local function sym_char_3f(b) - local b0 + local b0 = nil if ("number" == type(b)) then b0 = b else @@ -3721,25 +4132,29 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( return ((32 < b0) and not delims[b0] and (b0 ~= 127) and (b0 ~= 34) and (b0 ~= 39) and (b0 ~= 126) and (b0 ~= 59) and (b0 ~= 44) and (b0 ~= 64) and (b0 ~= 96)) end local prefixes = {[35] = "hashfn", [39] = "quote", [44] = "unquote", [96] = "quote"} + local nan, negative_nan = nil, nil + if (45 == string.byte(tostring((0 / 0)))) then + nan, negative_nan = ( - (0 / 0)), (0 / 0) + else + nan, negative_nan = (0 / 0), ( - (0 / 0)) + end local function char_starter_3f(b) - return ((function(_208_,_209_,_210_) return (_208_ < _209_) and (_209_ < _210_) end)(1,b,127) or (function(_211_,_212_,_213_) return (_211_ < _212_) and (_212_ < _213_) end)(192,b,247)) - end - local function parser_fn(getbyte, filename, _214_) - local _arg_215_ = _214_ - local source = _arg_215_["source"] - local unfriendly = _arg_215_["unfriendly"] - local comments = _arg_215_["comments"] - local options = _arg_215_ + return (((1 < b) and (b < 127)) or ((192 < b) and (b < 247))) + end + local function parser_fn(getbyte, filename, _215_0) + local _216_ = _215_0 + local options = _216_ + local comments = _216_["comments"] + local source = _216_["source"] + local unfriendly = _216_["unfriendly"] local stack = {} local line, byteindex, col, prev_col, lastb = 1, 0, 0, 0, nil local function ungetb(ub) if char_starter_3f(ub) then col = (col - 1) - else end if (ub == 10) then line, col = (line - 1), prev_col - else end byteindex = (byteindex - 1) lastb = ub @@ -3752,149 +4167,167 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( else r = getbyte({["stack-size"] = #stack}) end - byteindex = (byteindex + 1) + if r then + byteindex = (byteindex + 1) + end if (r and char_starter_3f(r)) then col = (col + 1) - else end if (r == 10) then line, col, prev_col = (line + 1), 0, col - else end return r end local function whitespace_3f(b) - local function _225_() - local t_224_ = options.whitespace - if (nil ~= t_224_) then - t_224_ = (t_224_)[b] - else + local function _224_() + local _223_0 = options.whitespace + if (nil ~= _223_0) then + _223_0 = _223_0[b] end - return t_224_ + return _223_0 end - return ((b == 32) or (function(_221_,_222_,_223_) return (_221_ <= _222_) and (_222_ <= _223_) end)(9,b,13) or _225_()) + return ((b == 32) or ((9 <= b) and (b <= 13)) or _224_()) end local function parse_error(msg, _3fcol_adjust) local col0 = (col + (_3fcol_adjust or -1)) if (nil == utils["hook-opts"]("parse-error", options, msg, filename, (line or "?"), col0, source, utils.root.reset)) then utils.root.reset() - if (unfriendly or not _G.io or not _G.io.read) then - return error(string.format("%s:%s:%s Parse error: %s", filename, (line or "?"), col0, msg), 0) + if unfriendly then + return error(string.format("%s:%s:%s: Parse error: %s", filename, (line or "?"), col0, msg), 0) else return friend["parse-error"](msg, filename, (line or "?"), col0, source, options) end - else - return nil end end local function parse_stream() local whitespace_since_dispatch, done_3f, retval = true local function set_source_fields(source0) - source0.byteend, source0.endcol = byteindex, (col - 1) + source0.byteend, source0.endcol, source0.endline = byteindex, (col - 1), line return nil end - local function dispatch(v) - local _229_ = stack[#stack] - if (_229_ == nil) then - retval, done_3f, whitespace_since_dispatch = v, true, false + local function dispatch(v, _3fsource, _3fraw) + whitespace_since_dispatch = false + local v0 = nil + do + local _228_0 = utils["hook-opts"]("parse-form", options, v, _3fsource, _3fraw, stack) + if (nil ~= _228_0) then + local hookv = _228_0 + v0 = hookv + else + local _ = _228_0 + v0 = v + end + end + local _230_0 = stack[#stack] + if (_230_0 == nil) then + retval, done_3f = v0, true return nil - elseif ((_G.type(_229_) == "table") and (nil ~= (_229_).prefix)) then - local prefix = (_229_).prefix - local source0 + elseif ((_G.type(_230_0) == "table") and (nil ~= _230_0.prefix)) then + local prefix = _230_0.prefix + local source0 = nil do - local _230_ = table.remove(stack) - set_source_fields(_230_) - source0 = _230_ - end - local list = utils.list(utils.sym(prefix, source0), v) - for k, v0 in pairs(source0) do - list[k] = v0 + local _231_0 = table.remove(stack) + set_source_fields(_231_0) + source0 = _231_0 end - return dispatch(list) - elseif (nil ~= _229_) then - local top = _229_ - whitespace_since_dispatch = false - return table.insert(top, v) - else - return nil + local list = utils.list(utils.sym(prefix, source0), v0) + return dispatch(utils.copy(source0, list)) + elseif (nil ~= _230_0) then + local top = _230_0 + return table.insert(top, v0) end end local function badend() - local accum = utils.map(stack, "closer") - local _232_ + local closers = nil + do + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for _, _233_0 in ipairs(stack) do + local _234_ = _233_0 + local closer = _234_["closer"] + local val_19_ = closer + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end + end + closers = tbl_17_ + end + local _236_ if (#stack == 1) then - _232_ = "" + _236_ = "" else - _232_ = "s" + _236_ = "s" end - return parse_error(string.format("expected closing delimiter%s %s", _232_, string.char(unpack(accum)))) + return parse_error(string.format("expected closing delimiter%s %s", _236_, string.char(unpack(closers))), 0) end - local function skip_whitespace(b) + local function skip_whitespace(b, close_table) if (b and whitespace_3f(b)) then whitespace_since_dispatch = true - return skip_whitespace(getb()) - elseif (not b and (0 < #stack)) then - return badend() + return skip_whitespace(getb(), close_table) + elseif (not b and next(stack)) then + badend() + for i = #stack, 2, -1 do + close_table(stack[i].closer) + end + return stack[1].closer else return b end end local function parse_comment(b, contents) if (b and (10 ~= b)) then - local function _236_() - local _235_ = contents - table.insert(_235_, string.char(b)) - return _235_ + local function _239_() + table.insert(contents, string.char(b)) + return contents end - return parse_comment(getb(), _236_()) + return parse_comment(getb(), _239_()) elseif comments then ungetb(10) - return dispatch(utils.comment(table.concat(contents), {line = line, filename = filename})) - else - return nil + return dispatch(utils.comment(table.concat(contents), {filename = filename, line = line})) end end local function open_table(b) if not whitespace_since_dispatch then parse_error(("expected whitespace before opening delimiter " .. string.char(b))) - else end - return table.insert(stack, {bytestart = byteindex, closer = delims[b], filename = filename, line = line, col = (col - 1)}) + return table.insert(stack, {bytestart = byteindex, closer = delims[b], col = (col - 1), filename = filename, line = line}) end local function close_list(list) return dispatch(setmetatable(list, getmetatable(utils.list()))) end local function close_sequence(tbl) - local val = utils.sequence(unpack(tbl)) + local mt = getmetatable(utils.sequence()) for k, v in pairs(tbl) do - getmetatable(val)[k] = v + if ("number" ~= type(k)) then + mt[k] = v + tbl[k] = nil + end end - return dispatch(val) + return dispatch(setmetatable(tbl, mt)) end local function add_comment_at(comments0, index, node) - local _239_ = (comments0)[index] - if (nil ~= _239_) then - local existing = _239_ + local _243_0 = comments0[index] + if (nil ~= _243_0) then + local existing = _243_0 return table.insert(existing, node) - elseif true then - local _ = _239_ - comments0[index] = {node} - return nil else + local _ = _243_0 + comments0[index] = {node} return nil end end local function next_noncomment(tbl, i) if utils["comment?"](tbl[i]) then return next_noncomment(tbl, (i + 1)) - elseif (utils.sym(":") == tbl[i]) then + elseif utils["sym?"](tbl[i], ":") then return tostring(tbl[(i + 1)]) else return tbl[i] end end local function extract_comments(tbl) - local comments0 = {keys = {}, values = {}, last = {}} + local comments0 = {keys = {}, last = {}, values = {}} while utils["comment?"](tbl[#tbl]) do table.insert(comments0.last, 1, table.remove(tbl)) end @@ -3911,7 +4344,6 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( for i = #tbl, 1, -1 do if utils["comment?"](tbl[i]) then table.remove(tbl, i) - else end end return comments0 @@ -3923,13 +4355,11 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( if ((#tbl % 2) ~= 0) then byteindex = (byteindex - 1) parse_error("expected even number of values in table literal") - else end setmetatable(val, tbl) for i = 1, #tbl, 2 do if ((tostring(tbl[i]) == ":") and utils["sym?"](tbl[(i + 1)]) and utils["sym?"](tbl[i])) then tbl[i] = tostring(tbl[(i + 1)]) - else end val[tbl[i]] = tbl[(i + 1)] table.insert(keys, tbl[i]) @@ -3942,11 +4372,9 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( local top = table.remove(stack) if (top == nil) then parse_error(("unexpected closing delimiter " .. string.char(b))) - else end if (top.closer and (top.closer ~= b)) then parse_error(("mismatched closing delimiter " .. string.char(b) .. ", expected " .. string.char(top.closer))) - else end set_source_fields(top) if (b == 41) then @@ -3958,22 +4386,22 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( end end local function parse_string_loop(chars, b, state) - table.insert(chars, b) - local state0 + if b then + table.insert(chars, string.char(b)) + end + local state0 = nil do - local _249_ = {state, b} - if ((_G.type(_249_) == "table") and ((_249_)[1] == "base") and ((_249_)[2] == 92)) then + local _254_0 = {state, b} + if ((_G.type(_254_0) == "table") and (_254_0[1] == "base") and (_254_0[2] == 92)) then state0 = "backslash" - elseif ((_G.type(_249_) == "table") and ((_249_)[1] == "base") and ((_249_)[2] == 34)) then + elseif ((_G.type(_254_0) == "table") and (_254_0[1] == "base") and (_254_0[2] == 34)) then state0 = "done" - elseif ((_G.type(_249_) == "table") and ((_249_)[1] == "backslash") and ((_249_)[2] == 10)) then + elseif ((_G.type(_254_0) == "table") and (_254_0[1] == "backslash") and (_254_0[2] == 10)) then table.remove(chars, (#chars - 1)) state0 = "base" - elseif true then - local _ = _249_ - state0 = "base" else - state0 = nil + local _ = _254_0 + state0 = "base" end end if (b and (state0 ~= "done")) then @@ -3983,70 +4411,69 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( end end local function escape_char(c) - return ({[7] = "\\a", [8] = "\\b", [9] = "\\t", [10] = "\\n", [11] = "\\v", [12] = "\\f", [13] = "\\r"})[c:byte()] + return ({[10] = "\\n", [11] = "\\v", [12] = "\\f", [13] = "\\r", [7] = "\\a", [8] = "\\b", [9] = "\\t"})[c:byte()] end - local function parse_string() + local function parse_string(source0) + if not whitespace_since_dispatch then + utils.warn("expected whitespace before string", nil, filename, line) + end table.insert(stack, {closer = 34}) - local chars = {34} + local chars = {"\""} if not parse_string_loop(chars, getb(), "base") then badend() - else end table.remove(stack) - local raw = string.char(unpack(chars)) + local raw = table.concat(chars) local formatted = raw:gsub("[\7-\13]", escape_char) - local _253_ = (rawget(_G, "loadstring") or load)(("return " .. formatted)) - if (nil ~= _253_) then - local load_fn = _253_ - return dispatch(load_fn()) - elseif (_253_ == nil) then + local _259_0 = (rawget(_G, "loadstring") or load)(("return " .. formatted)) + if (nil ~= _259_0) then + local load_fn = _259_0 + return dispatch(load_fn(), source0, raw) + elseif (_259_0 == nil) then return parse_error(("Invalid string: " .. raw)) - else - return nil end end local function parse_prefix(b) - table.insert(stack, {prefix = prefixes[b], filename = filename, line = line, bytestart = byteindex, col = (col - 1)}) + table.insert(stack, {bytestart = byteindex, col = (col - 1), filename = filename, line = line, prefix = prefixes[b]}) local nextb = getb() - if (whitespace_3f(nextb) or (true == delims[nextb])) then - if (b ~= 35) then - parse_error("invalid whitespace after quoting prefix") - else - end - table.remove(stack) - dispatch(utils.sym("#")) - else + local trailing_whitespace_3f = (whitespace_3f(nextb) or (true == delims[nextb])) + if (trailing_whitespace_3f and (b ~= 35)) then + parse_error("invalid whitespace after quoting prefix") + end + ungetb(nextb) + if (trailing_whitespace_3f and (b == 35)) then + local source0 = table.remove(stack) + set_source_fields(source0) + return dispatch(utils.sym("#", source0)) end - return ungetb(nextb) end local function parse_sym_loop(chars, b) if (b and sym_char_3f(b)) then - table.insert(chars, b) + table.insert(chars, string.char(b)) return parse_sym_loop(chars, getb()) else if b then ungetb(b) - else end return chars end end - local function parse_number(rawstr) - local number_with_stripped_underscores = (not rawstr:find("^_") and rawstr:gsub("_", "")) - if rawstr:match("^%d") then - dispatch((tonumber(number_with_stripped_underscores) or parse_error(("could not read number \"" .. rawstr .. "\"")))) + local function parse_number(rawstr, source0) + local trimmed = (not rawstr:find("^_") and rawstr:gsub("_", "")) + if ((trimmed == "nan") or (trimmed == "-nan")) then + return false + elseif rawstr:match("^%d") then + dispatch((tonumber(trimmed) or parse_error(("could not read number \"" .. rawstr .. "\""))), source0, rawstr) return true else - local _259_ = tonumber(number_with_stripped_underscores) - if (nil ~= _259_) then - local x = _259_ - dispatch(x) + local _265_0 = tonumber(trimmed) + if (nil ~= _265_0) then + local x = _265_0 + dispatch(x, source0, rawstr) return true - elseif true then - local _ = _259_ - return false else - return nil + local _ = _265_0 + return false end end end @@ -4055,35 +4482,41 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( return (rawstr:find(pat) - utils.len(rawstr) - 1) end if (rawstr:match("^~") and (rawstr ~= "~=")) then - return parse_error("invalid character: ~") - elseif rawstr:match("%.[0-9]") then - return parse_error(("can't start multisym segment with a digit: " .. rawstr), col_adjust("%.[0-9]")) + parse_error("invalid character: ~") elseif (rawstr:match("[%.:][%.:]") and (rawstr ~= "..") and (rawstr ~= "$...")) then - return parse_error(("malformed multisym: " .. rawstr), col_adjust("[%.:][%.:]")) + parse_error(("malformed multisym: " .. rawstr), col_adjust("[%.:][%.:]")) elseif ((rawstr ~= ":") and rawstr:match(":$")) then - return parse_error(("malformed multisym: " .. rawstr), col_adjust(":$")) + parse_error(("malformed multisym: " .. rawstr), col_adjust(":$")) elseif rawstr:match(":.+[%.:]") then - return parse_error(("method must be last component of multisym: " .. rawstr), col_adjust(":.+[%.:]")) - else - return rawstr + parse_error(("method must be last component of multisym: " .. rawstr), col_adjust(":.+[%.:]")) end + if not whitespace_since_dispatch then + utils.warn("expected whitespace before token", nil, filename, line) + end + return rawstr end local function parse_sym(b) - local source0 = {bytestart = byteindex, filename = filename, line = line, col = (col - 1)} - local rawstr = string.char(unpack(parse_sym_loop({b}, getb()))) + local source0 = {bytestart = byteindex, col = (col - 1), filename = filename, line = line} + local rawstr = table.concat(parse_sym_loop({string.char(b)}, getb())) set_source_fields(source0) if (rawstr == "true") then - return dispatch(true) + return dispatch(true, source0) elseif (rawstr == "false") then - return dispatch(false) + return dispatch(false, source0) elseif (rawstr == "...") then return dispatch(utils.varg(source0)) + elseif (rawstr == ".inf") then + return dispatch((1 / 0), source0, rawstr) + elseif (rawstr == "-.inf") then + return dispatch((-1 / 0), source0, rawstr) + elseif (rawstr == ".nan") then + return dispatch(nan, source0, rawstr) + elseif (rawstr == "-.nan") then + return dispatch(negative_nan, source0, rawstr) elseif rawstr:match("^:.+$") then - return dispatch(rawstr:sub(2)) - elseif not parse_number(rawstr) then + return dispatch(rawstr:sub(2), source0, rawstr) + elseif not parse_number(rawstr, source0) then return dispatch(utils.sym(check_malformed_sym(rawstr), source0)) - else - return nil end end local function parse_loop(b) @@ -4095,30 +4528,29 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( elseif delims[b] then close_table(b) elseif (b == 34) then - parse_string(b) + parse_string({bytestart = byteindex, col = col, filename = filename, line = line}) elseif prefixes[b] then parse_prefix(b) elseif (sym_char_3f(b) or (b == string.byte("~"))) then parse_sym(b) elseif not utils["hook-opts"]("illegal-char", options, b, getb, ungetb, dispatch) then parse_error(("invalid character: " .. string.char(b))) - else end if not b then return nil elseif done_3f then return true, retval else - return parse_loop(skip_whitespace(getb())) + return parse_loop(skip_whitespace(getb(), close_table)) end end - return parse_loop(skip_whitespace(getb())) + return parse_loop(skip_whitespace(getb(), close_table)) end - local function _266_() - stack, line, byteindex, col, lastb = {}, 1, 0, 0, nil + local function _273_() + stack, line, byteindex, col, lastb = {}, 1, 0, 0, ((lastb ~= 10) and lastb) return nil end - return parse_stream, _266_ + return parse_stream, _273_ end local function parser(stream_or_string, _3ffilename, _3foptions) local filename = (_3ffilename or "unknown") @@ -4130,110 +4562,96 @@ package.preload["fennel.parser"] = package.preload["fennel.parser"] or function( return parser_fn(stream_or_string, filename, options) end end - return {granulate = granulate, parser = parser, ["string-stream"] = string_stream, ["sym-char?"] = sym_char_3f} + return {["string-stream"] = string_stream, ["sym-char?"] = sym_char_3f, granulate = granulate, parser = parser} end -local utils +local utils = nil package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) - local type_order = {number = 1, boolean = 2, string = 3, table = 4, ["function"] = 5, userdata = 6, thread = 7} - local default_opts = {["one-line?"] = false, ["detect-cycles?"] = true, ["empty-as-sequence?"] = false, ["metamethod?"] = true, ["prefer-colon?"] = false, ["escape-newlines?"] = false, ["utf8?"] = true, ["line-length"] = 80, depth = 128, ["max-sparse-gap"] = 10} + local type_order = {["function"] = 5, boolean = 2, number = 1, string = 3, table = 4, thread = 7, userdata = 6} + local default_opts = {["detect-cycles?"] = true, ["empty-as-sequence?"] = false, ["escape-newlines?"] = false, ["line-length"] = 80, ["max-sparse-gap"] = 10, ["metamethod?"] = true, ["one-line?"] = false, ["prefer-colon?"] = false, ["utf8?"] = true, depth = 128} local lua_pairs = pairs local lua_ipairs = ipairs local function pairs(t) - local _1_ = getmetatable(t) - if ((_G.type(_1_) == "table") and (nil ~= (_1_).__pairs)) then - local p = (_1_).__pairs + local _1_0 = getmetatable(t) + if ((_G.type(_1_0) == "table") and (nil ~= _1_0.__pairs)) then + local p = _1_0.__pairs return p(t) - elseif true then - local _ = _1_ - return lua_pairs(t) else - return nil + local _ = _1_0 + return lua_pairs(t) end end local function ipairs(t) - local _3_ = getmetatable(t) - if ((_G.type(_3_) == "table") and (nil ~= (_3_).__ipairs)) then - local i = (_3_).__ipairs + local _3_0 = getmetatable(t) + if ((_G.type(_3_0) == "table") and (nil ~= _3_0.__ipairs)) then + local i = _3_0.__ipairs return i(t) - elseif true then - local _ = _3_ - return lua_ipairs(t) else - return nil + local _ = _3_0 + return lua_ipairs(t) end end local function length_2a(t) - local _5_ = getmetatable(t) - if ((_G.type(_5_) == "table") and (nil ~= (_5_).__len)) then - local l = (_5_).__len + local _5_0 = getmetatable(t) + if ((_G.type(_5_0) == "table") and (nil ~= _5_0.__len)) then + local l = _5_0.__len return l(t) - elseif true then - local _ = _5_ - return #t else - return nil + local _ = _5_0 + return #t end end local function get_default(key) - local _7_ = default_opts[key] - if (_7_ == nil) then + local _7_0 = default_opts[key] + if (_7_0 == nil) then return error(("option '%s' doesn't have a default value, use the :after key to set it"):format(tostring(key))) - elseif (nil ~= _7_) then - local v = _7_ + elseif (nil ~= _7_0) then + local v = _7_0 return v - else - return nil end end local function getopt(options, key) - local val = options[key] - local _9_ = val - if ((_G.type(_9_) == "table") and (nil ~= (_9_).once)) then - local val_2a = (_9_).once + local _9_0 = options[key] + if ((_G.type(_9_0) == "table") and (nil ~= _9_0.once)) then + local val_2a = _9_0.once return val_2a - elseif true then - local _ = _9_ - return val else - return nil + local _3fval = _9_0 + return _3fval end end local function normalize_opts(options) - local tbl_13_auto = {} + local tbl_14_ = {} for k, v in pairs(options) do - local k_14_auto, v_15_auto = nil, nil + local k_15_, v_16_ = nil, nil local function _12_() - local _11_ = v - if ((_G.type(_11_) == "table") and (nil ~= (_11_).after)) then - local val = (_11_).after + local _11_0 = v + if ((_G.type(_11_0) == "table") and (nil ~= _11_0.after)) then + local val = _11_0.after return val else local function _13_() return v.once end - if ((_G.type(_11_) == "table") and _13_()) then + if ((_G.type(_11_0) == "table") and _13_()) then return get_default(k) - elseif true then - local _ = _11_ - return v else - return nil + local _ = _11_0 + return v end end end - k_14_auto, v_15_auto = k, _12_() - if ((k_14_auto ~= nil) and (v_15_auto ~= nil)) then - tbl_13_auto[k_14_auto] = v_15_auto - else + k_15_, v_16_ = k, _12_() + if ((k_15_ ~= nil) and (v_16_ ~= nil)) then + tbl_14_[k_15_] = v_16_ end end - return tbl_13_auto + return tbl_14_ end - local function sort_keys(_16_, _18_) - local _arg_17_ = _16_ - local a = _arg_17_[1] - local _arg_19_ = _18_ - local b = _arg_19_[1] + local function sort_keys(_16_0, _18_0) + local _17_ = _16_0 + local a = _17_[1] + local _19_ = _18_0 + local b = _19_[1] local ta = type(a) local tb = type(b) if ((ta == tb) and ((ta == "string") or (ta == "number"))) then @@ -4256,25 +4674,23 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) local gap = 0 if (0 < length_2a(kv)) then local i = 0 - for _, _22_ in ipairs(kv) do - local _each_23_ = _22_ - local k = _each_23_[1] + for _, _22_0 in ipairs(kv) do + local _23_ = _22_0 + local k = _23_[1] if (gap < (k - i)) then gap = (k - i) - else end i = k end - else end return gap end local function fill_gaps(kv) local missing_indexes = {} local i = 0 - for _, _26_ in ipairs(kv) do - local _each_27_ = _26_ - local j = _each_27_[1] + for _, _26_0 in ipairs(kv) do + local _27_ = _26_0 + local j = _27_[1] i = (i + 1) while (i < j) do table.insert(missing_indexes, i) @@ -4293,7 +4709,6 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) for k, v in pairs(t) do if ((type(k) ~= "number") or (k < 1)) then assoc_3f = true - else end insert(kv, {k, v}) end @@ -4304,7 +4719,6 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) else fill_gaps(kv) end - else end if (length_2a(kv) == 0) then return kv, "empty" @@ -4330,40 +4744,34 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) else appearances[t] = ((appearances[t] or 0) + 1) end - else end return appearances end local function save_table(t, seen) local seen0 = (seen or {len = 0}) local id = (seen0.len + 1) - if not (seen0)[t] then + if not seen0[t] then seen0[t] = id seen0.len = id - else end return seen0 end - local function detect_cycle(t, seen, _3fk) + local function detect_cycle(t, seen) if ("table" == type(t)) then seen[t] = true - local _36_, _37_ = next(t, _3fk) - if ((nil ~= _36_) and (nil ~= _37_)) then - local k = _36_ - local v = _37_ - return (seen[k] or detect_cycle(k, seen) or seen[v] or detect_cycle(v, seen) or detect_cycle(t, seen, k)) - else - return nil + local res = nil + for k, v in pairs(t) do + if res then break end + res = (seen[k] or detect_cycle(k, seen) or seen[v] or detect_cycle(v, seen)) end - else - return nil + return res end end local function visible_cycle_3f(t, options) return (getopt(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(indent, id) - local opener_length + local opener_length = nil if id then opener_length = (length_2a(tostring(id)) + 2) else @@ -4374,16 +4782,16 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) local pp = nil local function concat_table_lines(elements, options, multiline_3f, indent, table_type, prefix, last_comment_3f) local indent_str = ("\n" .. string.rep(" ", indent)) - local open - local function _41_() + local open = nil + local function _38_() if ("seq" == table_type) then return "[" else return "{" end end - open = ((prefix or "") .. _41_()) - local close + open = ((prefix or "") .. _38_()) + local close = nil if ("seq" == table_type) then close = "]" else @@ -4391,14 +4799,14 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) end local oneline = (open .. table.concat(elements, " ") .. close) if (not getopt(options, "one-line?") and (multiline_3f or (options["line-length"] < (indent + length_2a(oneline))) or last_comment_3f)) then - local function _43_() + local function _40_() if last_comment_3f then return indent_str else return "" end end - return (open .. table.concat(elements, indent_str) .. _43_() .. close) + return (open .. table.concat(elements, indent_str) .. _40_() .. close) else return oneline end @@ -4429,44 +4837,43 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) local visible_cycle_3f0 = visible_cycle_3f(t, options) local id0 = (visible_cycle_3f0 and options.seen[t]) local indent0 = table_indent(indent, id0) - local slength + local slength = nil if getopt(options, "utf8?") then slength = utf8_len else - local function _46_(_241) + local function _43_(_241) return #_241 end - slength = _46_ + slength = _43_ end - local prefix + local prefix = nil if visible_cycle_3f0 then prefix = ("@" .. id0) else prefix = "" end - local items + local items = nil do local options0 = normalize_opts(options) - local tbl_16_auto = {} - local i_17_auto = #tbl_16_auto - for _, _49_ in ipairs(kv) do - local _each_50_ = _49_ - local k = _each_50_[1] - local v = _each_50_[2] - local val_18_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for _, _46_0 in ipairs(kv) do + local _47_ = _46_0 + local k = _47_[1] + local v = _47_[2] + local val_19_ = nil do local k0 = pp(k, options0, (indent0 + 1), true) local v0 = pp(v, options0, (indent0 + slength(k0) + 1)) multiline_3f = (multiline_3f or k0:find("\n") or v0:find("\n")) - val_18_auto = (k0 .. " " .. v0) + val_19_ = (k0 .. " " .. v0) end - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - items = tbl_16_auto + items = tbl_17_ end return concat_table_lines(items, options, multiline_3f, indent0, "table", prefix, false) end @@ -4482,35 +4889,34 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) local visible_cycle_3f0 = visible_cycle_3f(t, options) local id0 = (visible_cycle_3f0 and options.seen[t]) local indent0 = table_indent(indent, id0) - local prefix + local prefix = nil if visible_cycle_3f0 then prefix = ("@" .. id0) else prefix = "" end local last_comment_3f = comment_3f(t[#t]) - local items + local items = nil do local options0 = normalize_opts(options) - local tbl_16_auto = {} - local i_17_auto = #tbl_16_auto - for _, _54_ in ipairs(kv) do - local _each_55_ = _54_ - local _0 = _each_55_[1] - local v = _each_55_[2] - local val_18_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for _, _51_0 in ipairs(kv) do + local _52_ = _51_0 + local _0 = _52_[1] + local v = _52_[2] + local val_19_ = nil do local v0 = pp(v, options0, indent0) multiline_3f = (multiline_3f or v0:find("\n") or v0:find("^;")) - val_18_auto = v0 + val_19_ = v0 end - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - items = tbl_16_auto + items = tbl_17_ end return concat_table_lines(items, options, multiline_3f, indent0, "seq", prefix, last_comment_3f) end @@ -4523,22 +4929,21 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) return "{}" end else - local oneline - local _59_ + local oneline = nil + local _56_ do - local tbl_16_auto = {} - local i_17_auto = #tbl_16_auto + local tbl_17_ = {} + local i_18_ = #tbl_17_ for _, line in ipairs(lines) do - local val_18_auto = line:gsub("^%s+", "") - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto - else + local val_19_ = line:gsub("^%s+", "") + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - _59_ = tbl_16_auto + _56_ = tbl_17_ end - oneline = table.concat(_59_, " ") + oneline = table.concat(_56_, " ") if (not getopt(options, "one-line?") and (force_multi_line_3f or oneline:find("\n") or (options["line-length"] < (indent + length_2a(oneline))))) then return table.concat(lines, ("\n" .. string.rep(" ", indent))) else @@ -4554,11 +4959,11 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) return "{...}" end else - local _ - local function _64_(_241) + local _ = nil + local function _61_(_241) return visible_cycle_3f(_241, options) end - options["visible-cycle?"] = _64_ + options["visible-cycle?"] = _61_ _ = nil local lines, force_multi_line_3f = nil, nil do @@ -4566,92 +4971,132 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) lines, force_multi_line_3f = metamethod(t, pp, options0, indent) end options["visible-cycle?"] = nil - local _65_ = type(lines) - if (_65_ == "string") then + local _62_0 = type(lines) + if (_62_0 == "string") then return lines - elseif (_65_ == "table") then + elseif (_62_0 == "table") then return concat_lines(lines, options, indent, force_multi_line_3f) - elseif true then - local _0 = _65_ - return error("__fennelview metamethod must return a table of lines") else - return nil + local _0 = _62_0 + return error("__fennelview metamethod must return a table of lines") end end end local function pp_table(x, options, indent) options.level = (options.level + 1) - local x0 + local x0 = nil do - local _68_ + local _65_0 = nil if getopt(options, "metamethod?") then - local _69_ = x - if (nil ~= _69_) then - local _70_ = getmetatable(_69_) - if (nil ~= _70_) then - _68_ = (_70_).__fennelview + local _66_0 = x + if (nil ~= _66_0) then + local _67_0 = getmetatable(_66_0) + if (nil ~= _67_0) then + _65_0 = _67_0.__fennelview else - _68_ = _70_ + _65_0 = _67_0 end else - _68_ = _69_ + _65_0 = _66_0 end else - _68_ = nil + _65_0 = nil end - if (nil ~= _68_) then - local metamethod = _68_ + if (nil ~= _65_0) then + local metamethod = _65_0 x0 = pp_metamethod(x, metamethod, options, indent) - elseif true then - local _ = _68_ - local _74_, _75_ = table_kv_pairs(x, options) - if (true and (_75_ == "empty")) then - local _0 = _74_ + else + local _ = _65_0 + local _71_0, _72_0 = table_kv_pairs(x, options) + if (true and (_72_0 == "empty")) then + local _0 = _71_0 if getopt(options, "empty-as-sequence?") then x0 = "[]" else x0 = "{}" end - elseif ((nil ~= _74_) and (_75_ == "table")) then - local kv = _74_ + elseif ((nil ~= _71_0) and (_72_0 == "table")) then + local kv = _71_0 x0 = pp_associative(x, kv, options, indent) - elseif ((nil ~= _74_) and (_75_ == "seq")) then - local kv = _74_ + elseif ((nil ~= _71_0) and (_72_0 == "seq")) then + local kv = _71_0 x0 = pp_sequence(x, kv, options, indent) else - x0 = nil - end - else x0 = nil + end end end options.level = (options.level - 1) return x0 end - local function number__3estring(n) - local _79_ = string.gsub(tostring(n), ",", ".") - return _79_ + local function exponential_notation(n, fallback) + local s = nil + for i = 0, 308 do + if s then break end + local s0 = string.format(("%." .. i .. "e"), n) + if (n == tonumber(s0)) then + local exp = s0:match("e%+?(%d+)$") + if (exp and (14 < tonumber(exp))) then + s = s0 + else + s = fallback + end + else + s = nil + end + end + return s + end + local inf_str = tostring((1 / 0)) + local neg_inf_str = tostring((-1 / 0)) + local function number__3estring(n, options) + local val = nil + if (n ~= n) then + if (45 == string.byte(tostring(n))) then + val = (options["negative-nan"] or "-.nan") + else + val = (options.nan or ".nan") + end + elseif (math.floor(n) == n) then + local s1 = string.format("%.f", n) + if (s1 == inf_str) then + val = (options.infinity or ".inf") + elseif (s1 == neg_inf_str) then + val = (options["negative-infinity"] or "-.inf") + elseif (s1 == tostring(n)) then + val = s1 + else + val = (exponential_notation(n, s1) or s1) + end + else + val = tostring(n) + end + local _81_0 = string.gsub(val, ",", ".") + return _81_0 end local function colon_string_3f(s) - return s:find("^[-%w?^_!$%&*+./@|<=>]+$") + return s:find("^[-%w?^_!$%&*+./|<=>]+$") + end + local utf8_inits = {{["max-byte"] = 127, ["max-code"] = 127, ["min-byte"] = 0, ["min-code"] = 0, len = 1}, {["max-byte"] = 223, ["max-code"] = 2047, ["min-byte"] = 192, ["min-code"] = 128, len = 2}, {["max-byte"] = 239, ["max-code"] = 65535, ["min-byte"] = 224, ["min-code"] = 2048, len = 3}, {["max-byte"] = 247, ["max-code"] = 1114111, ["min-byte"] = 240, ["min-code"] = 65536, len = 4}} + local function default_byte_escape(byte, _options) + return ("\\%03d"):format(byte) end - local utf8_inits = {{["min-byte"] = 0, ["max-byte"] = 127, ["min-code"] = 0, ["max-code"] = 127, len = 1}, {["min-byte"] = 192, ["max-byte"] = 223, ["min-code"] = 128, ["max-code"] = 2047, len = 2}, {["min-byte"] = 224, ["max-byte"] = 239, ["min-code"] = 2048, ["max-code"] = 65535, len = 3}, {["min-byte"] = 240, ["max-byte"] = 247, ["min-code"] = 65536, ["max-code"] = 1114111, len = 4}} - local function utf8_escape(str) + local function utf8_escape(str, options) local function validate_utf8(str0, index) local inits = utf8_inits local byte = string.byte(str0, index) - local init + local init = nil do local ret = nil for _, init0 in ipairs(inits) do if ret then break end - ret = (byte and (function(_80_,_81_,_82_) return (_80_ <= _81_) and (_81_ <= _82_) end)(init0["min-byte"],byte,init0["max-byte"]) and init0) + ret = (byte and (function(_82_,_83_,_84_) return (_82_ <= _83_) and (_83_ <= _84_) end)(init0["min-byte"],byte,init0["max-byte"]) and init0) end init = ret end - local code - local function _83_() - local code0 + local code = nil + local function _85_() + local code0 = nil if init then code0 = (byte - init["min-byte"]) else @@ -4659,26 +5104,24 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) end for i = (index + 1), (index + init.len + -1) do local byte0 = string.byte(str0, i) - code0 = (byte0 and code0 and (function(_85_,_86_,_87_) return (_85_ <= _86_) and (_86_ <= _87_) end)(128,byte0,191) and ((code0 * 64) + (byte0 - 128))) + code0 = (byte0 and code0 and ((128 <= byte0) and (byte0 <= 191)) and ((code0 * 64) + (byte0 - 128))) end return code0 end - code = (init and _83_()) - if (code and (function(_88_,_89_,_90_) return (_88_ <= _89_) and (_89_ <= _90_) end)(init["min-code"],code,init["max-code"]) and not (function(_91_,_92_,_93_) return (_91_ <= _92_) and (_92_ <= _93_) end)(55296,code,57343)) then + code = (init and _85_()) + if (code and (function(_87_,_88_,_89_) return (_87_ <= _88_) and (_88_ <= _89_) end)(init["min-code"],code,init["max-code"]) and not ((55296 <= code) and (code <= 57343))) then return init.len - else - return nil end end local index = 1 local output = {} + local byte_escape = (getopt(options, "byte-escape") or default_byte_escape) while (index <= #str) do local nexti = (string.find(str, "[\128-\255]", index) or (#str + 1)) local len = validate_utf8(str, nexti) table.insert(output, string.sub(str, index, (nexti + (len or 0) + -1))) if (not len and (nexti <= #str)) then - table.insert(output, string.format("\\%03d", string.byte(str, nexti))) - else + table.insert(output, byte_escape(str:byte(nexti), options)) end if len then index = (nexti + len) @@ -4691,38 +5134,38 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) local function pp_string(str, options, indent) local len = length_2a(str) local esc_newline_3f = ((len < 2) or (getopt(options, "escape-newlines?") and (len < (options["line-length"] - indent)))) - local escs - local _97_ + local byte_escape = (getopt(options, "byte-escape") or default_byte_escape) + local escs = nil + local _93_ if esc_newline_3f then - _97_ = "\\n" + _93_ = "\\n" else - _97_ = "\n" + _93_ = "\n" end - local function _99_(_241, _242) - return ("\\%03d"):format(_242:byte()) + local function _95_(_241, _242) + return byte_escape(_242:byte(), options) end - escs = setmetatable({["\7"] = "\\a", ["\8"] = "\\b", ["\12"] = "\\f", ["\11"] = "\\v", ["\13"] = "\\r", ["\9"] = "\\t", ["\\"] = "\\\\", ["\""] = "\\\"", ["\n"] = _97_}, {__index = _99_}) + escs = setmetatable({["\""] = "\\\"", ["\11"] = "\\v", ["\12"] = "\\f", ["\13"] = "\\r", ["\7"] = "\\a", ["\8"] = "\\b", ["\9"] = "\\t", ["\\"] = "\\\\", ["\n"] = _93_}, {__index = _95_}) local str0 = ("\"" .. str:gsub("[%c\\\"]", escs) .. "\"") if getopt(options, "utf8?") then - return utf8_escape(str0) + return utf8_escape(str0, options) else return str0 end end local function make_options(t, options) - local defaults + local defaults = nil do - local tbl_13_auto = {} + local tbl_14_ = {} for k, v in pairs(default_opts) do - local k_14_auto, v_15_auto = k, v - if ((k_14_auto ~= nil) and (v_15_auto ~= nil)) then - tbl_13_auto[k_14_auto] = v_15_auto - else + local k_15_, v_16_ = k, v + if ((k_15_ ~= nil) and (v_16_ ~= nil)) then + tbl_14_[k_15_] = v_16_ end end - defaults = tbl_13_auto + defaults = tbl_14_ end - local overrides = {level = 0, appearances = count_table_appearances(t, {}), seen = {len = 0}} + local overrides = {appearances = count_table_appearances(t, {}), level = 0, seen = {len = 0}} for k, v in pairs((options or {})) do defaults[k] = v end @@ -4731,30 +5174,29 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) end return defaults end - local function _102_(x, options, indent, colon_3f) + local function _98_(x, options, indent, colon_3f) local indent0 = (indent or 0) local options0 = (options or make_options(x)) - local x0 + local x0 = nil if options0.preprocess then x0 = options0.preprocess(x, options0) else x0 = x end local tv = type(x0) - local function _105_() - local _104_ = getmetatable(x0) - if (nil ~= _104_) then - return (_104_).__fennelview - else - return _104_ + local function _101_() + local _100_0 = getmetatable(x0) + if ((_G.type(_100_0) == "table") and true) then + local __fennelview = _100_0.__fennelview + return __fennelview end end - if ((tv == "table") or ((tv == "userdata") and _105_())) then + if ((tv == "table") or ((tv == "userdata") and _101_())) then return pp_table(x0, options0, indent0) elseif (tv == "number") then - return number__3estring(x0) + return number__3estring(x0, options0) else - local function _107_() + local function _103_() if (colon_3f ~= nil) then return colon_3f elseif ("function" == type(options0["prefer-colon?"])) then @@ -4763,7 +5205,7 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) return getopt(options0, "prefer-colon?") end end - if ((tv == "string") and colon_string_3f(x0) and _107_()) then + if ((tv == "string") and colon_string_3f(x0) and _103_()) then return (":" .. x0) elseif (tv == "string") then return pp_string(x0, options0, indent0) @@ -4774,20 +5216,20 @@ package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) end end end - pp = _102_ - local function view(x, _3foptions) + pp = _98_ + local function _view(x, _3foptions) return pp(x, make_options(x, _3foptions), 0) end - return view + return _view end package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(...) local view = require("fennel.view") - local version = "1.3.0" + local version = "1.5.1" local function luajit_vm_3f() return ((nil ~= _G.jit) and (type(_G.jit) == "table") and (nil ~= _G.jit.on) and (nil ~= _G.jit.off) and (type(_G.jit.version_num) == "number")) end local function luajit_vm_version() - local jit_os + local jit_os = nil if (_G.jit.os == "OSX") then jit_os = "macOS" else @@ -4810,200 +5252,160 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. return ("PUC " .. _VERSION) end end - local function runtime_version() - return ("Fennel " .. version .. " on " .. lua_vm_version()) - end - local function warn(message) - if (_G.io and _G.io.stderr) then - return (_G.io.stderr):write(("--WARNING: %s\n"):format(tostring(message))) + local function runtime_version(_3fas_table) + if _3fas_table then + return {fennel = version, lua = lua_vm_version()} else - return nil + return ("Fennel " .. version .. " on " .. lua_vm_version()) end end - local len + local len = nil do - local _112_, _113_ = pcall(require, "utf8") - if ((_112_ == true) and (nil ~= _113_)) then - local utf8 = _113_ + local _108_0, _109_0 = pcall(require, "utf8") + if ((_108_0 == true) and (nil ~= _109_0)) then + local utf8 = _109_0 len = utf8.len - elseif true then - local _ = _112_ - len = string.len else - len = nil + local _ = _108_0 + len = string.len end end - local function mt_keys_in_order(t, out, used_keys) - for _, k in ipairs(getmetatable(t).keys) do - if (t[k] and not used_keys[k]) then - used_keys[k] = true - table.insert(out, k) - else + local kv_order = {boolean = 2, number = 1, string = 3, table = 4} + local function kv_compare(a, b) + local _111_0, _112_0 = type(a), type(b) + if (((_111_0 == "number") and (_112_0 == "number")) or ((_111_0 == "string") and (_112_0 == "string"))) then + return (a < b) + else + local function _113_() + local a_t = _111_0 + local b_t = _112_0 + return (a_t ~= b_t) end - end - for k in pairs(t) do - if not used_keys[k] then - table.insert(out, k) + if (((nil ~= _111_0) and (nil ~= _112_0)) and _113_()) then + local a_t = _111_0 + local b_t = _112_0 + return ((kv_order[a_t] or 5) < (kv_order[b_t] or 5)) else + local _ = _111_0 + return (tostring(a) < tostring(b)) end end - return out end - local function stablepairs(t) - local keys - local _118_ + local function add_stable_keys(succ, prev_key, src, _3fpred) + local first = prev_key + local last = nil do - local t_117_ = getmetatable(t) - if (nil ~= t_117_) then - t_117_ = (t_117_).keys - else - end - _118_ = t_117_ - end - if _118_ then - keys = mt_keys_in_order(t, {}, {}) - else - local _120_ - do - local tbl_16_auto = {} - local i_17_auto = #tbl_16_auto - for k in pairs(t) do - local val_18_auto = k - if (nil ~= val_18_auto) then - i_17_auto = (i_17_auto + 1) - do end (tbl_16_auto)[i_17_auto] = val_18_auto + local prev = prev_key + for _, k in ipairs(src) do + if ((prev == k) or (succ[k] ~= nil) or (_3fpred and not _3fpred(k))) then + prev = prev + else + if (first == nil) then + first = k + prev = k + elseif (prev ~= nil) then + succ[prev] = k + prev = k else + prev = k end end - _120_ = tbl_16_auto - end - local function _122_(_241, _242) - return (tostring(_241) < tostring(_242)) end - table.sort(_120_, _122_) - keys = _120_ + last = prev end - local succ + return succ, last, first + end + local function stablepairs(t) + local mt_keys = nil do - local tbl_13_auto = {} - for i, k in ipairs(keys) do - local k_14_auto, v_15_auto = k, keys[(i + 1)] - if ((k_14_auto ~= nil) and (v_15_auto ~= nil)) then - tbl_13_auto[k_14_auto] = v_15_auto - else - end + local _117_0 = getmetatable(t) + if (nil ~= _117_0) then + _117_0 = _117_0.keys end - succ = tbl_13_auto + mt_keys = _117_0 end - local function stablenext(tbl, key) - local next_key - if (key == nil) then - next_key = keys[1] - else - next_key = succ[key] - end - return next_key, tbl[next_key] + local succ, prev, first_mt = nil, nil, nil + local function _119_(_241) + return t[_241] end - return stablenext, t, nil - end - local function get_in(tbl, path, _3ffallback) - assert(("table" == type(tbl)), "get-in expects path to be a table") - if (0 == #path) then - return _3ffallback - else - local _126_ + succ, prev, first_mt = add_stable_keys({}, nil, (mt_keys or {}), _119_) + local pairs_keys = nil + do + local _120_0 = nil do - local t = tbl - for _, k in ipairs(path) do - if (nil == t) then break end - local _127_ = type(t) - if (_127_ == "table") then - t = t[k] - else - t = nil + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for k in pairs(t) do + local val_19_ = k + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ end end - _126_ = t - end - if (nil ~= _126_) then - local res = _126_ - return res - elseif true then - local _ = _126_ - return _3ffallback - else - return nil + _120_0 = tbl_17_ end + table.sort(_120_0, kv_compare) + pairs_keys = _120_0 end - end - local function map(t, f, _3fout) - local out = (_3fout or {}) - local f0 - if (type(f) == "function") then - f0 = f + local succ0, _, first_after_mt = add_stable_keys(succ, prev, pairs_keys) + local first = nil + if (first_mt == nil) then + first = first_after_mt else - local function _131_(_241) - return (_241)[f] - end - f0 = _131_ + first = first_mt end - for _, x in ipairs(t) do - local _133_ = f0(x) - if (nil ~= _133_) then - local v = _133_ - table.insert(out, v) + local function stablenext(tbl, key) + local _123_0 = nil + if (key == nil) then + _123_0 = first else + _123_0 = succ0[key] + end + if (nil ~= _123_0) then + local next_key = _123_0 + local _125_0 = tbl[next_key] + if (_125_0 ~= nil) then + return next_key, _125_0 + else + return _125_0 + end end end - return out + return stablenext, t, nil end - local function kvmap(t, f, _3fout) - local out = (_3fout or {}) - local f0 - if (type(f) == "function") then - f0 = f - else - local function _135_(_241) - return (_241)[f] - end - f0 = _135_ - end - for k, x in stablepairs(t) do - local _137_, _138_ = f0(k, x) - if ((nil ~= _137_) and (nil ~= _138_)) then - local key = _137_ - local value = _138_ - out[key] = value - elseif (nil ~= _137_) then - local value = _137_ - table.insert(out, value) - else + local function get_in(tbl, path) + if (nil ~= path[1]) then + local t = tbl + for _, k in ipairs(path) do + if (nil == t) then break end + if (type(t) == "table") then + t = t[k] + else + t = nil + end end + return t end - return out end - local function copy(from, _3fto) - local tbl_13_auto = (_3fto or {}) - for k, v in pairs((from or {})) do - local k_14_auto, v_15_auto = k, v - if ((k_14_auto ~= nil) and (v_15_auto ~= nil)) then - tbl_13_auto[k_14_auto] = v_15_auto - else + local function copy(_3ffrom, _3fto) + local tbl_14_ = (_3fto or {}) + for k, v in pairs((_3ffrom or {})) do + local k_15_, v_16_ = k, v + if ((k_15_ ~= nil) and (v_16_ ~= nil)) then + tbl_14_[k_15_] = v_16_ end end - return tbl_13_auto + return tbl_14_ end local function member_3f(x, tbl, _3fn) - local _141_ = tbl[(_3fn or 1)] - if (_141_ == x) then + local _131_0 = tbl[(_3fn or 1)] + if (_131_0 == x) then return true - elseif (_141_ == nil) then + elseif (_131_0 == nil) then return nil - elseif true then - local _ = _141_ - return member_3f(x, tbl, ((_3fn or 1) + 1)) else - return nil + local _ = _131_0 + return member_3f(x, tbl, ((_3fn or 1) + 1)) end end local function maxn(tbl) @@ -5017,9 +5419,9 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. end return max end - local function every_3f(predicate, seq) + local function every_3f(t, predicate) local result = true - for _, item in ipairs(seq) do + for _, item in ipairs(t) do if not result then break end result = predicate(item) end @@ -5037,17 +5439,13 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. seen[next_state] = true return next_state, value else - local _144_ = getmetatable(t) - if ((_G.type(_144_) == "table") and true) then - local __index = (_144_).__index + local _134_0 = getmetatable(t) + if ((_G.type(_134_0) == "table") and true) then + local __index = _134_0.__index if ("table" == type(__index)) then t = __index return allpairs_next(t) - else - return nil end - else - return nil end end end @@ -5056,23 +5454,26 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. local function deref(self) return self[1] end - local nil_sym = nil local function list__3estring(self, _3fview, _3foptions, _3findent) - local safe = {} - local view0 - if _3fview then - local function _148_(_241) - return _3fview(_241, _3foptions, _3findent) + local viewed = nil + do + local tbl_17_ = {} + local i_18_ = #tbl_17_ + for i = 1, maxn(self) do + local val_19_ = nil + if _3fview then + val_19_ = _3fview(self[i], _3foptions, _3findent) + else + val_19_ = view(self[i]) + end + if (nil ~= val_19_) then + i_18_ = (i_18_ + 1) + tbl_17_[i_18_] = val_19_ + end end - view0 = _148_ - else - view0 = view + viewed = tbl_17_ end - local max = maxn(self) - for i = 1, max do - safe[i] = (((self[i] == nil) and nil_sym) or self[i]) - end - return ("(" .. table.concat(map(safe, view0), " ", 1, max) .. ")") + return ("(" .. table.concat(viewed, " ") .. ")") end local function comment_view(c) return c, true @@ -5083,21 +5484,21 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. local function sym_3c(a, b) return (a[1] < tostring(b)) end - local symbol_mt = {__fennelview = deref, __tostring = deref, __eq = sym_3d, __lt = sym_3c, "SYMBOL"} - local expr_mt - local function _150_(x) + local symbol_mt = {"SYMBOL", __eq = sym_3d, __fennelview = deref, __lt = sym_3c, __tostring = deref} + local expr_mt = nil + local function _140_(x) return tostring(deref(x)) end - expr_mt = {__tostring = _150_, "EXPR"} - local list_mt = {__fennelview = list__3estring, __tostring = list__3estring, "LIST"} - local comment_mt = {__fennelview = comment_view, __tostring = deref, __eq = sym_3d, __lt = sym_3c, "COMMENT"} + expr_mt = {"EXPR", __tostring = _140_} + local list_mt = {"LIST", __fennelview = list__3estring, __tostring = list__3estring} + local comment_mt = {"COMMENT", __eq = sym_3d, __fennelview = comment_view, __lt = sym_3c, __tostring = deref} local sequence_marker = {"SEQUENCE"} - local varg_mt = {__fennelview = deref, __tostring = deref, "VARARG"} - local getenv - local function _151_() + local varg_mt = {"VARARG", __fennelview = deref, __tostring = deref} + local getenv = nil + local function _141_() return nil end - getenv = ((os and os.getenv) or _151_) + getenv = ((os and os.getenv) or _141_) local function debug_on_3f(flag) local level = (getenv("FENNEL_DEBUG") or "") return ((level == "all") or level:find(flag)) @@ -5106,67 +5507,63 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. return setmetatable({...}, list_mt) end local function sym(str, _3fsource) - local _152_ + local _142_ do - local tbl_13_auto = {str} + local tbl_14_ = {str} for k, v in pairs((_3fsource or {})) do - local k_14_auto, v_15_auto = nil, nil + local k_15_, v_16_ = nil, nil if (type(k) == "string") then - k_14_auto, v_15_auto = k, v + k_15_, v_16_ = k, v else - k_14_auto, v_15_auto = nil + k_15_, v_16_ = nil end - if ((k_14_auto ~= nil) and (v_15_auto ~= nil)) then - tbl_13_auto[k_14_auto] = v_15_auto - else + if ((k_15_ ~= nil) and (v_16_ ~= nil)) then + tbl_14_[k_15_] = v_16_ end end - _152_ = tbl_13_auto + _142_ = tbl_14_ end - return setmetatable(_152_, symbol_mt) + return setmetatable(_142_, symbol_mt) end - nil_sym = sym("nil") local function sequence(...) - local function _155_(seq, view0, inspector, indent) - local opts + local function _145_(seq, view0, inspector, indent) + local opts = nil do - local _156_ = inspector - _156_["empty-as-sequence?"] = {once = true, after = inspector["empty-as-sequence?"]} - _156_["metamethod?"] = {once = false, after = inspector["metamethod?"]} - opts = _156_ + inspector["empty-as-sequence?"] = {after = inspector["empty-as-sequence?"], once = true} + inspector["metamethod?"] = {after = inspector["metamethod?"], once = false} + opts = inspector end return view0(seq, opts, indent) end - return setmetatable({...}, {sequence = sequence_marker, __fennelview = _155_}) + return setmetatable({...}, {__fennelview = _145_, sequence = sequence_marker}) end local function expr(strcode, etype) - return setmetatable({type = etype, strcode}, expr_mt) + return setmetatable({strcode, type = etype}, expr_mt) end local function comment_2a(contents, _3fsource) - local _let_157_ = (_3fsource or {}) - local filename = _let_157_["filename"] - local line = _let_157_["line"] - return setmetatable({filename = filename, line = line, contents}, comment_mt) + local _146_ = (_3fsource or {}) + local filename = _146_["filename"] + local line = _146_["line"] + return setmetatable({contents, filename = filename, line = line}, comment_mt) end local function varg(_3fsource) - local _158_ + local _147_ do - local tbl_13_auto = {"..."} + local tbl_14_ = {"..."} for k, v in pairs((_3fsource or {})) do - local k_14_auto, v_15_auto = nil, nil + local k_15_, v_16_ = nil, nil if (type(k) == "string") then - k_14_auto, v_15_auto = k, v + k_15_, v_16_ = k, v else - k_14_auto, v_15_auto = nil + k_15_, v_16_ = nil end - if ((k_14_auto ~= nil) and (v_15_auto ~= nil)) then - tbl_13_auto[k_14_auto] = v_15_auto - else + if ((k_15_ ~= nil) and (v_16_ ~= nil)) then + tbl_14_[k_15_] = v_16_ end end - _158_ = tbl_13_auto + _147_ = tbl_14_ end - return setmetatable(_158_, varg_mt) + return setmetatable(_147_, varg_mt) end local function expr_3f(x) return ((type(x) == "table") and (getmetatable(x) == expr_mt) and x) @@ -5177,8 +5574,8 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. local function list_3f(x) return ((type(x) == "table") and (getmetatable(x) == list_mt) and x) end - local function sym_3f(x) - return ((type(x) == "table") and (getmetatable(x) == symbol_mt) and x) + local function sym_3f(x, _3fname) + return ((type(x) == "table") and (getmetatable(x) == symbol_mt) and ((nil == _3fname) or (x[1] == _3fname)) and x) end local function sequence_3f(x) local mt = ((type(x) == "table") and getmetatable(x)) @@ -5190,8 +5587,25 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. local function table_3f(x) return ((type(x) == "table") and not varg_3f(x) and (getmetatable(x) ~= list_mt) and (getmetatable(x) ~= symbol_mt) and not comment_3f(x) and x) end + local function kv_table_3f(t) + if table_3f(t) then + local nxt, t0, k = pairs(t) + local len0 = #t0 + local next_state = nil + if (0 == len0) then + next_state = k + else + next_state = len0 + end + return ((nil ~= nxt(t0, next_state)) and t0) + end + end local function string_3f(x) - return (type(x) == "string") + if (type(x) == "string") then + return x + else + return false + end end local function multi_sym_3f(str) if sym_3f(str) then @@ -5199,138 +5613,182 @@ package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(.. elseif (type(str) ~= "string") then return false else - local function _161_() + local function _153_() local parts = {} for part in str:gmatch("[^%.%:]+[%.%:]?") do - local last_char = part:sub(( - 1)) + local last_char = part:sub(-1) if (last_char == ":") then parts["multi-sym-method-call"] = true - else end if ((last_char == ":") or (last_char == ".")) then - parts[(#parts + 1)] = part:sub(1, ( - 2)) + parts[(#parts + 1)] = part:sub(1, -2) else parts[(#parts + 1)] = part end end - return ((0 < #parts) and parts) + return (next(parts) and parts) end - return ((str:match("%.") or str:match(":")) and not str:match("%.%.") and (str:byte() ~= string.byte(".")) and (str:byte(( - 1)) ~= string.byte(".")) and _161_()) + return ((str:match("%.") or str:match(":")) and not str:match("%.%.") and (str:byte() ~= string.byte(".")) and (str:byte() ~= string.byte(":")) and (str:byte(-1) ~= string.byte(".")) and (str:byte(-1) ~= string.byte(":")) and _153_()) end end + local function call_of_3f(ast, callee) + return (list_3f(ast) and sym_3f(ast[1], callee)) + end local function quoted_3f(symbol) return symbol.quoted end local function idempotent_expr_3f(x) - return ((type(x) == "string") or (type(x) == "integer") or (type(x) == "number") or (sym_3f(x) and not multi_sym_3f(x))) - end - local function ast_source(ast) - if (table_3f(ast) or sequence_3f(ast)) then - return (getmetatable(ast) or {}) - elseif ("table" == type(ast)) then - return ast - else - return {} - end + local t = type(x) + return ((t == "string") or (t == "number") or (t == "boolean") or (sym_3f(x) and not multi_sym_3f(x))) end local function walk_tree(root, f, _3fcustom_iterator) local function walk(iterfn, parent, idx, node) - if f(idx, node, parent) then + if (f(idx, node, parent) and not sym_3f(node)) then for k, v in iterfn(node) do walk(iterfn, node, k, v) end return nil - else - return nil end end walk((_3fcustom_iterator or pairs), nil, nil, root) return root end - local lua_keywords = {"and", "break", "do", "else", "elseif", "end", "false", "for", "function", "if", "in", "local", "nil", "not", "or", "repeat", "return", "then", "true", "until", "while", "goto"} - for i, v in ipairs(lua_keywords) do - lua_keywords[v] = i + local root = nil + local function _158_() + end + root = {chunk = nil, options = nil, reset = _158_, scope = nil} + root["set-reset"] = function(_159_0) + local _160_ = _159_0 + local chunk = _160_["chunk"] + local options = _160_["options"] + local reset = _160_["reset"] + local scope = _160_["scope"] + root.reset = function() + root.chunk, root.scope, root.options, root.reset = chunk, scope, options, reset + return nil + end + return root.reset + end + local lua_keywords = {["and"] = true, ["break"] = true, ["do"] = true, ["else"] = true, ["elseif"] = true, ["end"] = true, ["false"] = true, ["for"] = true, ["function"] = true, ["goto"] = true, ["if"] = true, ["in"] = true, ["local"] = true, ["nil"] = true, ["not"] = true, ["or"] = true, ["repeat"] = true, ["return"] = true, ["then"] = true, ["true"] = true, ["until"] = true, ["while"] = true} + local function lua_keyword_3f(str) + local function _162_() + local _161_0 = root.options + if (nil ~= _161_0) then + _161_0 = _161_0.keywords + end + if (nil ~= _161_0) then + _161_0 = _161_0[str] + end + return _161_0 + end + return (lua_keywords[str] or _162_()) end local function valid_lua_identifier_3f(str) - return (str:match("^[%a_][%w_]*$") and not lua_keywords[str]) + return (str:match("^[%a_][%w_]*$") and not lua_keyword_3f(str)) end local propagated_options = {"allowedGlobals", "indent", "correlate", "useMetadata", "env", "compiler-env", "compilerEnv"} local function propagate_options(options, subopts) + local tbl_14_ = subopts for _, name in ipairs(propagated_options) do - subopts[name] = options[name] + local k_15_, v_16_ = name, options[name] + if ((k_15_ ~= nil) and (v_16_ ~= nil)) then + tbl_14_[k_15_] = v_16_ + end end - return subopts + return tbl_14_ end - local root - local function _167_() + local function ast_source(ast) + if (table_3f(ast) or sequence_3f(ast)) then + return (getmetatable(ast) or {}) + elseif ("table" == type(ast)) then + return ast + else + return {} + end end - root = {chunk = nil, scope = nil, options = nil, reset = _167_} - root["set-reset"] = function(_168_) - local _arg_169_ = _168_ - local chunk = _arg_169_["chunk"] - local scope = _arg_169_["scope"] - local options = _arg_169_["options"] - local reset = _arg_169_["reset"] - root.reset = function() - root.chunk, root.scope, root.options, root.reset = chunk, scope, options, reset - return nil + local function warn(msg, _3fast, _3ffilename, _3fline) + local _167_0 = nil + do + local _168_0 = root.options + if (nil ~= _168_0) then + _168_0 = _168_0.warn + end + _167_0 = _168_0 + end + if (nil ~= _167_0) then + local opt_warn = _167_0 + return opt_warn(msg, _3fast, _3ffilename, _3fline) + else + local _ = _167_0 + if (_G.io and _G.io.stderr) then + local loc = nil + do + local _170_0 = ast_source(_3fast) + if ((_G.type(_170_0) == "table") and (nil ~= _170_0.filename) and (nil ~= _170_0.line)) then + local filename = _170_0.filename + local line = _170_0.line + loc = (filename .. ":" .. line .. ": ") + else + local _0 = _170_0 + if (_3ffilename and _3fline) then + loc = (_3ffilename .. ":" .. _3fline .. ": ") + else + loc = "" + end + end + end + return (_G.io.stderr):write(("--WARNING: %s%s\n"):format(loc, msg)) + end end - return root.reset end local warned = {} - local function check_plugin_version(_170_) - local _arg_171_ = _170_ - local name = _arg_171_["name"] - local versions = _arg_171_["versions"] - local plugin = _arg_171_ - if (not member_3f(version:gsub("-dev", ""), (versions or {})) and not warned[plugin]) then + local function check_plugin_version(_175_0) + local _176_ = _175_0 + local plugin = _176_ + local name = _176_["name"] + local versions = _176_["versions"] + if (not member_3f(version:gsub("-dev", ""), (versions or {})) and not (string_3f(versions) and version:find(versions)) and not warned[plugin]) then warned[plugin] = true return warn(string.format("plugin %s does not support Fennel version %s", (name or "unknown"), version)) - else - return nil end end local function hook_opts(event, _3foptions, ...) - local plugins - local function _174_(...) - local t_173_ = _3foptions - if (nil ~= t_173_) then - t_173_ = (t_173_).plugins - else + local plugins = nil + local function _179_(...) + local _178_0 = _3foptions + if (nil ~= _178_0) then + _178_0 = _178_0.plugins end - return t_173_ + return _178_0 end - local function _177_(...) - local t_176_ = root.options - if (nil ~= t_176_) then - t_176_ = (t_176_).plugins - else + local function _182_(...) + local _181_0 = root.options + if (nil ~= _181_0) then + _181_0 = _181_0.plugins end - return t_176_ + return _181_0 end - plugins = (_174_(...) or _177_(...)) + plugins = (_179_(...) or _182_(...)) if plugins then local result = nil for _, plugin in ipairs(plugins) do - if result then break end + if (nil ~= result) then break end check_plugin_version(plugin) - local _179_ = plugin[event] - if (nil ~= _179_) then - local f = _179_ + local _184_0 = plugin[event] + if (nil ~= _184_0) then + local f = _184_0 result = f(...) else - result = nil + result = nil end end return result - else - return nil end end local function hook(event, ...) return hook_opts(event, root.options, ...) end - return {warn = warn, allpairs = allpairs, stablepairs = stablepairs, copy = copy, ["get-in"] = get_in, kvmap = kvmap, map = map, ["walk-tree"] = walk_tree, ["member?"] = member_3f, maxn = maxn, ["every?"] = every_3f, list = list, sequence = sequence, sym = sym, varg = varg, expr = expr, comment = comment_2a, ["comment?"] = comment_3f, ["expr?"] = expr_3f, ["list?"] = list_3f, ["multi-sym?"] = multi_sym_3f, ["sequence?"] = sequence_3f, ["sym?"] = sym_3f, ["table?"] = table_3f, ["varg?"] = varg_3f, ["quoted?"] = quoted_3f, ["string?"] = string_3f, ["idempotent-expr?"] = idempotent_expr_3f, ["valid-lua-identifier?"] = valid_lua_identifier_3f, ["lua-keywords"] = lua_keywords, hook = hook, ["hook-opts"] = hook_opts, ["propagate-options"] = propagate_options, root = root, ["debug-on?"] = debug_on_3f, ["ast-source"] = ast_source, version = version, ["runtime-version"] = runtime_version, len = len, path = table.concat({"./?.fnl", "./?/init.fnl", getenv("FENNEL_PATH")}, ";"), ["macro-path"] = table.concat({"./?.fnl", "./?/init-macros.fnl", "./?/init.fnl", getenv("FENNEL_MACRO_PATH")}, ";")} + return {["ast-source"] = ast_source, ["call-of?"] = call_of_3f, ["comment?"] = comment_3f, ["debug-on?"] = debug_on_3f, ["every?"] = every_3f, ["expr?"] = expr_3f, ["fennel-module"] = nil, ["get-in"] = get_in, ["hook-opts"] = hook_opts, ["idempotent-expr?"] = idempotent_expr_3f, ["kv-table?"] = kv_table_3f, ["list?"] = list_3f, ["lua-keyword?"] = lua_keyword_3f, ["macro-path"] = table.concat({"./?.fnl", "./?/init-macros.fnl", "./?/init.fnl", getenv("FENNEL_MACRO_PATH")}, ";"), ["member?"] = member_3f, ["multi-sym?"] = multi_sym_3f, ["propagate-options"] = propagate_options, ["quoted?"] = quoted_3f, ["runtime-version"] = runtime_version, ["sequence?"] = sequence_3f, ["string?"] = string_3f, ["sym?"] = sym_3f, ["table?"] = table_3f, ["valid-lua-identifier?"] = valid_lua_identifier_3f, ["varg?"] = varg_3f, ["walk-tree"] = walk_tree, allpairs = allpairs, comment = comment_2a, copy = copy, expr = expr, hook = hook, len = len, list = list, maxn = maxn, path = table.concat({"./?.fnl", "./?/init.fnl", getenv("FENNEL_PATH")}, ";"), root = root, sequence = sequence, stablepairs = stablepairs, sym = sym, varg = varg, version = version, warn = warn} end utils = require("fennel.utils") local parser = require("fennel.parser") @@ -5343,7 +5801,6 @@ local function eval_env(env, opts) local env0 = specials["make-compiler-env"](nil, compiler.scopes.compiler, {}, opts) if (opts.allowedGlobals == nil) then opts.allowedGlobals = specials["current-global-names"](env0) - else end return specials["wrap-env"](env0) else @@ -5354,36 +5811,33 @@ local function eval_opts(options, str) local opts = utils.copy(options) if (opts.allowedGlobals == nil) then opts.allowedGlobals = specials["current-global-names"](opts.env) - else end if (not opts.filename and not opts.source) then opts.source = str - else end if (opts.env == "_COMPILER") then opts.scope = compiler["make-scope"](compiler.scopes.compiler) - else end return opts end -local function eval(str, options, ...) - local opts = eval_opts(options, str) +local function eval(str, _3foptions, ...) + local opts = eval_opts(_3foptions, str) local env = eval_env(opts.env, opts) local lua_source = compiler["compile-string"](str, opts) - local loader - local function _753_(...) + local loader = nil + local function _841_(...) if opts.filename then return ("@" .. opts.filename) else return str end end - loader = specials["load-code"](lua_source, env, _753_(...)) + loader = specials["load-code"](lua_source, env, _841_(...)) opts.filename = nil return loader(...) end -local function dofile_2a(filename, options, ...) - local opts = utils.copy(options) +local function dofile_2a(filename, _3foptions, ...) + local opts = utils.copy(_3foptions) local f = assert(io.open(filename, "rb")) local source = assert(f:read("*all"), ("Could not read " .. filename)) f:close() @@ -5394,32 +5848,33 @@ local function syntax() local body_3f = {"when", "with-open", "collect", "icollect", "fcollect", "lambda", "\206\187", "macro", "match", "match-try", "case", "case-try", "accumulate", "faccumulate", "doto"} local binding_3f = {"collect", "icollect", "fcollect", "each", "for", "let", "with-open", "accumulate", "faccumulate"} local define_3f = {"fn", "lambda", "\206\187", "var", "local", "macro", "macros", "global"} + local deprecated = {"~=", "#", "global", "require-macros", "pick-args"} local out = {} for k, v in pairs(compiler.scopes.global.specials) do local metadata = (compiler.metadata[v] or {}) - do end (out)[k] = {["special?"] = true, ["body-form?"] = metadata["fnl/body-form?"], ["binding-form?"] = utils["member?"](k, binding_3f), ["define?"] = utils["member?"](k, define_3f)} + out[k] = {["binding-form?"] = utils["member?"](k, binding_3f), ["body-form?"] = metadata["fnl/body-form?"], ["define?"] = utils["member?"](k, define_3f), ["deprecated?"] = utils["member?"](k, deprecated), ["special?"] = true} end - for k, v in pairs(compiler.scopes.global.macros) do - out[k] = {["macro?"] = true, ["body-form?"] = utils["member?"](k, body_3f), ["binding-form?"] = utils["member?"](k, binding_3f), ["define?"] = utils["member?"](k, define_3f)} + for k in pairs(compiler.scopes.global.macros) do + out[k] = {["binding-form?"] = utils["member?"](k, binding_3f), ["body-form?"] = utils["member?"](k, body_3f), ["define?"] = utils["member?"](k, define_3f), ["macro?"] = true} end for k, v in pairs(_G) do - local _754_ = type(v) - if (_754_ == "function") then - out[k] = {["global?"] = true, ["function?"] = true} - elseif (_754_ == "table") then - for k2, v2 in pairs(v) do - if (("function" == type(v2)) and (k ~= "_G")) then - out[(k .. "." .. k2)] = {["function?"] = true, ["global?"] = true} - else + local _842_0 = type(v) + if (_842_0 == "function") then + out[k] = {["function?"] = true, ["global?"] = true} + elseif (_842_0 == "table") then + if not k:find("^_") then + for k2, v2 in pairs(v) do + if ("function" == type(v2)) then + out[(k .. "." .. k2)] = {["function?"] = true, ["global?"] = true} + end end + out[k] = {["global?"] = true} end - out[k] = {["global?"] = true} - else end end return out end -local mod = {list = utils.list, ["list?"] = utils["list?"], sym = utils.sym, ["sym?"] = utils["sym?"], ["multi-sym?"] = utils["multi-sym?"], sequence = utils.sequence, ["sequence?"] = utils["sequence?"], ["table?"] = utils["table?"], comment = utils.comment, ["comment?"] = utils["comment?"], varg = utils.varg, ["varg?"] = utils["varg?"], ["sym-char?"] = parser["sym-char?"], parser = parser.parser, compile = compiler.compile, ["compile-string"] = compiler["compile-string"], ["compile-stream"] = compiler["compile-stream"], eval = eval, repl = repl, view = view, dofile = dofile_2a, ["load-code"] = specials["load-code"], doc = specials.doc, metadata = compiler.metadata, traceback = compiler.traceback, version = utils.version, ["runtime-version"] = utils["runtime-version"], ["ast-source"] = utils["ast-source"], path = utils.path, ["macro-path"] = utils["macro-path"], ["macro-loaded"] = specials["macro-loaded"], ["macro-searchers"] = specials["macro-searchers"], ["search-module"] = specials["search-module"], ["make-searcher"] = specials["make-searcher"], searcher = specials["make-searcher"](), syntax = syntax, gensym = compiler.gensym, scope = compiler["make-scope"], mangle = compiler["global-mangling"], unmangle = compiler["global-unmangling"], compile1 = compiler.compile1, ["string-stream"] = parser["string-stream"], granulate = parser.granulate, loadCode = specials["load-code"], make_searcher = specials["make-searcher"], makeSearcher = specials["make-searcher"], searchModule = specials["search-module"], macroPath = utils["macro-path"], macroSearchers = specials["macro-searchers"], macroLoaded = specials["macro-loaded"], compileStream = compiler["compile-stream"], compileString = compiler["compile-string"], stringStream = parser["string-stream"], runtimeVersion = utils["runtime-version"]} +local mod = {["ast-source"] = utils["ast-source"], ["comment?"] = utils["comment?"], ["compile-stream"] = compiler["compile-stream"], ["compile-string"] = compiler["compile-string"], ["list?"] = utils["list?"], ["load-code"] = specials["load-code"], ["macro-loaded"] = specials["macro-loaded"], ["macro-path"] = utils["macro-path"], ["macro-searchers"] = specials["macro-searchers"], ["make-searcher"] = specials["make-searcher"], ["multi-sym?"] = utils["multi-sym?"], ["runtime-version"] = utils["runtime-version"], ["search-module"] = specials["search-module"], ["sequence?"] = utils["sequence?"], ["string-stream"] = parser["string-stream"], ["sym-char?"] = parser["sym-char?"], ["sym?"] = utils["sym?"], ["table?"] = utils["table?"], ["varg?"] = utils["varg?"], 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, getinfo = compiler.getinfo, granulate = parser.granulate, list = utils.list, loadCode = specials["load-code"], macroLoaded = specials["macro-loaded"], macroPath = utils["macro-path"], macroSearchers = specials["macro-searchers"], makeSearcher = specials["make-searcher"], make_searcher = specials["make-searcher"], mangle = compiler["global-mangling"], metadata = compiler.metadata, parser = parser.parser, path = utils.path, repl = repl, runtimeVersion = utils["runtime-version"], scope = compiler["make-scope"], searchModule = specials["search-module"], searcher = specials["make-searcher"](), sequence = utils.sequence, stringStream = parser["string-stream"], sym = utils.sym, syntax = syntax, traceback = compiler.traceback, unmangle = compiler["global-unmangling"], varg = utils.varg, version = utils.version, view = view} mod.install = function(_3fopts) table.insert((package.searchers or package.loaders), specials["make-searcher"](_3fopts)) return mod @@ -5427,20 +5882,23 @@ end utils["fennel-module"] = mod do local module_name = "fennel.macros" - local _ - local function _757_() + local _ = nil + local function _846_() return mod end - package.preload[module_name] = _757_ + package.preload[module_name] = _846_ _ = nil - local env + local env = nil do - local _758_ = specials["make-compiler-env"](nil, compiler.scopes.compiler, {}) - do end (_758_)["utils"] = utils - _758_["fennel"] = mod - env = _758_ + local _847_0 = specials["make-compiler-env"](nil, compiler.scopes.compiler, {}) + _847_0["utils"] = utils + _847_0["fennel"] = mod + _847_0["get-function-metadata"] = specials["get-function-metadata"] + env = _847_0 end - local built_ins = eval([===[;; These macros are awkward because their definition cannot rely on the any + local built_ins = eval([===[;; fennel-ls: macro-file + + ;; These macros are awkward because their definition cannot rely on the any ;; built-in macros, only special forms. (no when, no icollect, etc) (fn copy [t] @@ -5475,26 +5933,28 @@ do Same as -> except will short-circuit with nil when it encounters a nil value." (if (= nil ?e) val - (let [el (if (list? ?e) (copy ?e) (list ?e)) - tmp (gensym)] - (table.insert el 2 tmp) - `(let [,tmp ,val] - (if (not= nil ,tmp) - (-?> ,el ,...) - ,tmp))))) + (not (utils.idempotent-expr? val)) + ;; try again, but with an eval-safe val + `(let [tmp# ,val] + (-?> tmp# ,?e ,...)) + (let [call (if (list? ?e) (copy ?e) (list ?e))] + (table.insert call 2 val) + `(if (not= nil ,val) + ,(-?>* call ...))))) (fn -?>>* [val ?e ...] "Nil-safe thread-last macro. Same as ->> except will short-circuit with nil when it encounters a nil value." (if (= nil ?e) val - (let [el (if (list? ?e) (copy ?e) (list ?e)) - tmp (gensym)] - (table.insert el tmp) - `(let [,tmp ,val] - (if (not= ,tmp nil) - (-?>> ,el ,...) - ,tmp))))) + (not (utils.idempotent-expr? val)) + ;; try again, but with an eval-safe val + `(let [tmp# ,val] + (-?>> tmp# ,?e ,...)) + (let [call (if (list? ?e) (copy ?e) (list ?e))] + (table.insert call val) + `(if (not= ,val nil) + ,(-?>>* call ...))))) (fn ?dot [tbl ...] "Nil-safe table look up. @@ -5504,26 +5964,26 @@ do lookups `(do (var ,head ,tbl) ,head)] - (each [_ k (ipairs [...])] + (each [i k (ipairs [...])] ;; Kinda gnarly to reassign in place like this, but it emits the best lua. ;; With this impl, it emits a flat, concise, and readable set of ifs - (table.insert lookups (# lookups) `(if (not= nil ,head) - (set ,head (. ,head ,k))))) + (table.insert lookups (+ i 2) + `(if (not= nil ,head) (set ,head (. ,head ,k))))) lookups)) (fn doto* [val ...] "Evaluate val and splice it into the first argument of subsequent forms." (assert (not= val nil) "missing subject") - (let [rebind? (or (not (sym? val)) - (multi-sym? val)) - name (if rebind? (gensym) val) - form (if rebind? `(let [,name ,val]) `(do))] - (each [_ elt (ipairs [...])] - (let [elt (if (list? elt) (copy elt) (list elt))] - (table.insert elt 2 name) - (table.insert form elt))) - (table.insert form name) - form)) + (if (not (utils.idempotent-expr? val)) + `(let [tmp# ,val] + (doto tmp# ,...)) + (let [form `(do)] + (each [_ elt (ipairs [...])] + (let [elt (if (list? elt) (copy elt) (list elt))] + (table.insert elt 2 val) + (table.insert form elt))) + (table.insert form val) + form))) (fn when* [condition body1 ...] "Evaluate body for side-effects only when condition is truthy." @@ -5541,7 +6001,8 @@ do ,...) closer `(fn close-handlers# [ok# ...] (if ok# ... (error ... 0))) - traceback `(. (or package.loaded.fennel debug) :traceback)] + traceback `(. (or (. package.loaded ,(fennel-module-name)) _G.debug {}) + :traceback)] (for [i 1 (length closable-bindings) 2] (assert (sym? (. closable-bindings i)) "with-open only allows symbols in bindings") @@ -5554,8 +6015,7 @@ do (var (into iter-out found?) (values [] (copy iter-tbl))) (for [i (length iter-tbl) 2 -1] (let [item (. iter-tbl i)] - (if (or (= `&into item) - (= :into item)) + (if (or (sym? item "&into") (= :into item)) (do (assert (not found?) "expected only one &into clause") (set found? true) @@ -5564,7 +6024,7 @@ do (table.remove iter-out i))))) (assert (or (not found?) (sym? into) (table? into) (list? into)) "expected table, function call, or symbol in &into clause") - (values into iter-out)) + (values into iter-out found?)) (fn collect* [iter-tbl key-expr value-expr ...] "Return a table made by running an iterator and evaluating an expression that @@ -5585,6 +6045,7 @@ do (assert (not= nil key-expr) "expected key and value expression") (assert (= nil ...) "expected 1 or 2 body expressions; wrap multiple expressions with do") + (assert (or value-expr (list? key-expr)) "need key and value") (let [kv-expr (if (= nil value-expr) key-expr `(values ,key-expr ,value-expr)) (into iter) (extract-into iter-tbl)] `(let [tbl# ,into] @@ -5602,17 +6063,23 @@ do (assert (not= nil value-expr) "expected table value expression") (assert (= nil ...) "expected exactly one body expression. Wrap multiple expressions in do") - (let [(into iter) (extract-into iter-tbl)] - `(let [tbl# ,into] - ;; believe it or not, using a var here has a pretty good performance - ;; boost: https://p.hagelb.org/icollect-performance.html - (var i# (length tbl#)) - (,how ,iter - (let [val# ,value-expr] - (when (not= nil val#) - (set i# (+ i# 1)) - (tset tbl# i# val#)))) - tbl#))) + (let [(into iter has-into?) (extract-into iter-tbl)] + (if has-into? + `(let [tbl# ,into] + (,how ,iter (let [val# ,value-expr] + (table.insert tbl# val#))) + tbl#) + ;; believe it or not, using a var here has a pretty good performance + ;; boost: https://p.hagelb.org/icollect-performance.html + ;; but it doesn't always work with &into clauses, so skip if that's used + `(let [tbl# []] + (var i# 0) + (,how ,iter + (let [val# ,value-expr] + (when (not= nil val#) + (set i# (+ i# 1)) + (tset tbl# i# val#)))) + tbl#)))) (fn icollect* [iter-tbl value-expr ...] "Return a sequential table made by running an iterator and evaluating an @@ -5692,17 +6159,13 @@ do numerical range like `for` rather than an iterator." (accumulate-impl true iter-tbl body ...)) - (fn double-eval-safe? [x type] - (or (= :number type) (= :string type) (= :boolean type) - (and (sym? x) (not (multi-sym? x))))) - (fn partial* [f ...] "Return a function with all arguments partially applied to f." (assert f "expected a function to partially apply") (let [bindings [] args []] (each [_ arg (ipairs [...])] - (if (double-eval-safe? arg (type arg)) + (if (utils.idempotent-expr? arg) (table.insert args arg) (let [name (gensym)] (table.insert bindings name) @@ -5711,68 +6174,39 @@ do (let [body (list f (unpack args))] (table.insert body _VARARG) ;; only use the extra let if we need double-eval protection - (if (= 0 (length bindings)) + (if (= nil (. bindings 1)) `(fn [,_VARARG] ,body) `(let ,bindings (fn [,_VARARG] ,body)))))) (fn pick-args* [n f] - "Create a function of arity n that applies its arguments to f. - - For example, - (pick-args 2 func) - expands to - (fn [_0_ _1_] (func _0_ _1_))" + "Create a function of arity n that applies its arguments to f. Deprecated." (if (and _G.io _G.io.stderr) (_G.io.stderr:write "-- WARNING: pick-args is deprecated and will be removed in the future.\n")) - (assert (and (= (type n) :number) (= n (math.floor n)) (<= 0 n)) - (.. "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))))) - - (fn pick-values* [n ...] - "Evaluate to exactly n values. - - For example, - (pick-values 2 ...) - expands to - (let [(_0_ _1_) ...] - (values _0_ _1_))" - (assert (and (= :number (type n)) (<= 0 n) (= n (math.floor n))) - (.. "Expected n to be an integer >= 0, got " (tostring n))) - (let [let-syms (list) - let-values (if (= 1 (select "#" ...)) ... `(values ,...))] - (for [i 1 n] - (table.insert let-syms (gensym))) - (if (= n 0) `(values) - `(let [,let-syms ,let-values] - (values ,(unpack let-syms)))))) + (for [i 1 n] (tset bindings i (gensym))) + `(fn ,bindings (,f ,(unpack bindings))))) (fn lambda* [...] "Function literal with nil-checked arguments. Like `fn`, but will throw an exception if a declared argument is passed in as nil, unless that argument's name begins with a question mark." (let [args [...] + args-len (length args) has-internal-name? (sym? (. args 1)) arglist (if has-internal-name? (. args 2) (. args 1)) - docstring-position (if has-internal-name? 3 2) - has-docstring? (and (< docstring-position (length args)) - (= :string (type (. args docstring-position)))) - arity-check-position (- 4 (if has-internal-name? 0 1) - (if has-docstring? 0 1)) - empty-body? (< (length args) arity-check-position)] + metadata-position (if has-internal-name? 3 2) + (_ check-position) (get-function-metadata [:lambda ...] arglist + metadata-position) + empty-body? (< args-len check-position)] (fn check! [a] (if (table? a) - (each [_ a (pairs a)] - (check! a)) + (each [_ a (pairs a)] (check! a)) (let [as (tostring a)] - (and (not (as:match "^?")) (not= as "&") (not= as "_") + (and (not (as:find "^?")) (not= as "&") (not (as:find "^_")) (not= as "...") (not= as "&as"))) - (table.insert args arity-check-position + (table.insert args check-position `(_G.assert (not= nil ,a) ,(: "Missing argument %s on %s:%s" :format (tostring a) @@ -5780,10 +6214,8 @@ do (or a.line "?")))))) (assert (= :table (type arglist)) "expected arg list") - (each [_ a (ipairs arglist)] - (check! a)) - (if empty-body? - (table.insert args (sym :nil))) + (each [_ a (ipairs arglist)] (check! a)) + (if empty-body? (table.insert args (sym :nil))) `(fn ,(unpack args)))) (fn macro* [name ...] @@ -5796,7 +6228,9 @@ do "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))))) + ;; TODO: Provide a helpful compiler error in the unlikely edge case of an + ;; infinite AST instead of the current "silently expand until max depth" + `(,handle ,(view (macroexpand form _SCOPE) {:detect-cycles? false})))) (fn import-macros* [binding1 module-name1 ...] "Bind a table of macros from each macro module according to a binding form. @@ -5831,6 +6265,32 @@ do (tset scope.macros import-key (. macros* macro-name)))))) nil) + (fn assert-repl* [condition ...] + "Enter into a debug REPL and print the message when condition is false/nil. + Works as a drop-in replacement for Lua's `assert`. + REPL `,return` command returns values to assert in place to continue execution." + {:fnl/arglist [condition ?message ...]} + (fn add-locals [{: symmeta : parent} locals] + (each [name (pairs symmeta)] + (tset locals name (sym name))) + (if parent (add-locals parent locals) locals)) + `(let [unpack# (or table.unpack _G.unpack) + pack# (or table.pack #(doto [$...] (tset :n (select :# $...)))) + ;; need to pack/unpack input args to account for (assert (foo)), + ;; because assert returns *all* arguments upon success + vals# (pack# ,condition ,...) + condition# (. vals# 1) + message# (or (. vals# 2) "assertion failed, entering repl.")] + (if (not condition#) + (let [opts# {:assert-repl? true} + fennel# (require ,(fennel-module-name)) + locals# ,(add-locals (get-scope) [])] + (set opts#.message (fennel#.traceback message#)) + (set opts#.env (collect [k# v# (pairs _G) &into locals#] + (if (= nil (. locals# k#)) (values k# v#)))) + (_G.assert (fennel#.repl opts#))) + (values (unpack# vals# 1 vals#.n))))) + {:-> ->* :->> ->>* :-?> -?>* @@ -5848,22 +6308,28 @@ do :lambda lambda* :λ lambda* :pick-args pick-args* - :pick-values pick-values* :macro macro* :macrodebug macrodebug* - :import-macros import-macros*} - ]===], {env = env, scope = compiler.scopes.compiler, useMetadata = true, filename = "src/fennel/macros.fnl", moduleName = module_name}) - local _0 + :import-macros import-macros* + :assert-repl assert-repl*} + ]===], {env = env, filename = "src/fennel/macros.fnl", moduleName = module_name, scope = compiler.scopes.compiler, useMetadata = true}) + local _0 = nil for k, v in pairs(built_ins) do compiler.scopes.global.macros[k] = v end _0 = nil - local match_macros = eval([===[;;; Pattern matching + local match_macros = eval([===[;; fennel-ls: macro-file + + ;;; Pattern matching ;; This is separated out so we can use the "core" macros during the ;; implementation of pattern matching. (fn copy [t] (collect [k v (pairs t)] k v)) + (fn double-eval-safe? [x type] + (or (= :number type) (= :string type) (= :boolean type) + (and (sym? x) (not (multi-sym? x))))) + (fn with [opts k] (doto (copy opts) (tset k true))) @@ -5880,11 +6346,11 @@ do (icollect [_ b (ipairs subbindings) &into bindings] b))) (values condition bindings))) - (fn case-table [val pattern unifications case-pattern opts] - (let [condition `(and (= (_G.type ,val) :table)) + (fn case-table [val pattern unifications case-pattern opts ?top] + (let [condition (if (= :table ?top) `(and) `(and (= (_G.type ,val) :table))) bindings []] (each [k pat (pairs pattern)] - (if (= pat `&) + (if (sym? pat :&) (let [rest-pat (. pattern (+ k 1)) rest-val `(select ,k ((or table.unpack _G.unpack) ,val)) subcondition (case-table `(pick-values 1 ,rest-val) @@ -5896,19 +6362,19 @@ do "expected & rest argument before last parameter") (table.insert bindings rest-pat) (table.insert bindings [rest-val])) - (= k `&as) + (sym? k :&as) (do (table.insert bindings pat) (table.insert bindings val)) - (and (= :number (type k)) (= `&as pat)) + (and (= :number (type k)) (sym? pat :&as)) (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))))) + (or (not= :number (type k)) (and (not (sym? (. pattern (- k 1)) :&as)) + (not (sym? (. pattern (- k 1)) :&)))) (let [subval `(. ,val ,k) (subcondition subbindings) (case-pattern [subval] pat unifications @@ -5918,27 +6384,30 @@ do (values condition bindings))) (fn case-guard [vals condition guards unifications case-pattern opts] - (if (= 0 (length guards)) - (case-pattern vals condition unifications opts) + (if (. guards 1) (let [(pcondition bindings) (case-pattern vals condition unifications opts) condition `(and ,(unpack guards))] (values `(and ,pcondition (let ,bindings - ,condition)) bindings)))) + ,condition)) bindings)) + (case-pattern vals condition unifications opts))) (fn symbols-in-pattern [pattern] "gives the set of symbols inside a pattern" (if (list? pattern) - (let [result {}] - (each [_ child-pattern (ipairs pattern)] - (collect [name symbol (pairs (symbols-in-pattern child-pattern)) &into result] - name symbol)) - result) + (if (or (sym? (. pattern 1) :where) + (sym? (. pattern 1) :=)) + (symbols-in-pattern (. pattern 2)) + (sym? (. pattern 2) :?) + (symbols-in-pattern (. pattern 1)) + (let [result {}] + (each [_ child-pattern (ipairs pattern)] + (collect [name symbol (pairs (symbols-in-pattern child-pattern)) &into result] + name symbol)) + result)) (sym? pattern) - (if (and (not= pattern `or) - (not= pattern `where) - (not= pattern `?) - (not= pattern `nil)) + (if (and (not (sym? pattern :or)) + (not (sym? pattern :nil))) {(tostring pattern) pattern} {}) (= (type pattern) :table) @@ -5958,7 +6427,7 @@ do (let [in-pattern (symbols-in-pattern pattern)] (if ?symbols (do - (each [name symbol (pairs ?symbols)] + (each [name (pairs ?symbols)] (when (not (. in-pattern name)) (tset ?symbols name nil))) ?symbols) @@ -5970,24 +6439,21 @@ do (fn case-or [vals pattern guards unifications case-pattern opts] (let [pattern [(unpack pattern 2)] - bindings (symbols-in-every-pattern pattern opts.infer-unification?)] ;; TODO opts.infer-unification instead of opts.unification? - (if (= 0 (length bindings)) - ;; no bindings special case generates simple code - (let [condition - (icollect [i subpattern (ipairs pattern) &into `(or)] - (let [(subcondition subbindings) (case-pattern vals subpattern unifications opts)] - subcondition))] - (values - (if (= 0 (length guards)) - condition - `(and ,condition ,(unpack guards))) - [])) + bindings (symbols-in-every-pattern pattern opts.infer-unification?)] + (if (= nil (. bindings 1)) + ;; no bindings special case generates simple code + (let [condition (icollect [_ subpattern (ipairs pattern) &into `(or)] + (case-pattern vals subpattern unifications opts))] + (values (if (. guards 1) + `(and ,condition ,(unpack guards)) + condition) + [])) ;; case with bindings is handled specially, and returns three values instead of two (let [matched? (gensym :matched?) bindings-mangled (icollect [_ binding (ipairs bindings)] (gensym (tostring binding))) pre-bindings `(if)] - (each [i subpattern (ipairs pattern)] + (each [_ subpattern (ipairs pattern)] (let [(subcondition subbindings) (case-guard vals subpattern guards {} case-pattern opts)] (table.insert pre-bindings subcondition) (table.insert pre-bindings `(let ,subbindings @@ -5996,7 +6462,7 @@ do [`(,(unpack bindings)) `(values ,(unpack bindings-mangled))] [`(,matched? ,(unpack bindings-mangled)) pre-bindings]))))) - (fn case-pattern [vals pattern unifications opts top-level?] + (fn case-pattern [vals pattern unifications opts ?top] "Take the AST of values and a single pattern and returns a condition to determine if it matches as well as a list of bindings to introduce for the duration of the body if it does match." @@ -6021,10 +6487,10 @@ do ;; of vals) or we're not, in which case we only care about the first one. (let [[val] vals] (if (and (sym? pattern) - (or (= pattern `nil) + (or (sym? pattern :nil) (and opts.infer-unification? (in-scope? pattern) - (not= pattern `_)) + (not (sym? pattern :_))) (and opts.infer-unification? (multi-sym? pattern) (in-scope? (. (multi-sym? pattern) 1))))) @@ -6040,33 +6506,33 @@ do `(not= ,(sym :nil) ,val)) [pattern val])) ;; opt-in unify with (=) (and (list? pattern) - (= (. pattern 1) `=) + (sym? (. pattern 1) :=) (sym? (. pattern 2))) (let [bind (. pattern 2)] (assert-compile (= 2 (length pattern)) "(=) should take only one argument" pattern) (assert-compile (not opts.infer-unification?) "(=) cannot be used inside of match" pattern) (assert-compile opts.in-where? "(=) must be used in (where) patterns" pattern) - (assert-compile (and (sym? bind) (not= bind `nil) "= has to bind to a symbol" bind)) + (assert-compile (and (sym? bind) (not (sym? bind :nil)) "= has to bind to a symbol" bind)) (values `(= ,val ,bind) [])) ;; where-or clause - (and (list? pattern) (= (. pattern 1) `where) (list? (. pattern 2)) (= (. pattern 2 1) `or)) + (and (list? pattern) (sym? (. pattern 1) :where) (list? (. pattern 2)) (sym? (. pattern 2 1) :or)) (do - (assert-compile top-level? "can't nest (where) pattern" pattern) + (assert-compile ?top "can't nest (where) pattern" pattern) (case-or vals (. pattern 2) [(unpack pattern 3)] unifications case-pattern (with opts :in-where?))) ;; where clause - (and (list? pattern) (= (. pattern 1) `where)) + (and (list? pattern) (sym? (. pattern 1) :where)) (do - (assert-compile top-level? "can't nest (where) pattern" pattern) + (assert-compile ?top "can't nest (where) pattern" pattern) (case-guard vals (. pattern 2) [(unpack pattern 3)] unifications case-pattern (with opts :in-where?))) ;; or clause (not allowed on its own) - (and (list? pattern) (= (. pattern 1) `or)) + (and (list? pattern) (sym? (. pattern 1) :or)) (do - (assert-compile top-level? "can't nest (or) pattern" pattern) + (assert-compile ?top "can't nest (or) pattern" pattern) ;; This assertion can be removed to make patterns more permissive (assert-compile false "(or) must be used in (where) patterns" pattern) (case-or vals pattern [] unifications case-pattern opts)) ;; guard clause - (and (list? pattern) (= (. pattern 2) `?)) + (and (list? pattern) (sym? (. pattern 2) :?)) (do (assert-compile opts.legacy-guard-allowed? "legacy guard clause not supported in case" pattern) (case-guard vals (. pattern 1) [(unpack pattern 3)] unifications case-pattern opts)) @@ -6077,7 +6543,7 @@ do (case-values vals pattern unifications case-pattern opts)) ;; table patterns (= (type pattern) :table) - (case-table val pattern unifications case-pattern opts) + (case-table val pattern unifications case-pattern opts ?top) ;; literal value (values `(= ,val ,pattern) [])))) @@ -6095,7 +6561,7 @@ do ;; otherwise, keep growing the current `if` AST. out)) - (fn case-condition [vals clauses match?] + (fn case-condition [vals clauses match? top-table?] "Construct the actual `if` AST for the given match values and clauses." ;; root is the original `if` AST. ;; out is the `if` AST that is currently being grown. @@ -6108,22 +6574,21 @@ do {:multival? true :infer-unification? match? :legacy-guard-allowed? match?} - true) + (if top-table? :table true)) out (add-pre-bindings out pre-bindings)] ;; grow the `if` AST by one extra condition (table.insert out condition) - (table.insert out `(let ,bindings - ,body)) + (table.insert out `(let ,bindings ,body)) out)) root)) (fn count-case-multival [pattern] "Identify the amount of multival values that a pattern requires." - (if (and (list? pattern) (= (. pattern 2) `?)) + (if (and (list? pattern) (sym? (. pattern 2) :?)) (count-case-multival (. pattern 1)) - (and (list? pattern) (= (. pattern 1) `where)) + (and (list? pattern) (sym? (. pattern 1) :where)) (count-case-multival (. pattern 2)) - (and (list? pattern) (= (. pattern 1) `or)) + (and (list? pattern) (sym? (. pattern 1) :or)) (accumulate [longest 0 _ child-pattern (ipairs pattern)] (math.max longest (count-case-multival child-pattern))) @@ -6131,29 +6596,43 @@ do (length pattern) 1)) - (fn case-val-syms [clauses] - "What is the length of the largest multi-valued clause? return a list of that - many gensyms." + (fn case-count-syms [clauses] + "Find the length of the largest multi-valued clause" (let [patterns (fcollect [i 1 (length clauses) 2] - (. clauses i)) - sym-count (accumulate [longest 0 - _ pattern (ipairs patterns)] - (math.max longest (count-case-multival pattern)))] - (fcollect [i 1 sym-count &into (list)] - (gensym)))) + (. clauses i))] + (accumulate [longest 0 + _ pattern (ipairs patterns)] + (math.max longest (count-case-multival pattern))))) - (fn case-impl [match? val ...] + (fn maybe-optimize-table [val clauses] + (if (faccumulate [all (sequence? val) i 1 (length clauses) 2 &until (not all)] + (and (sequence? (. clauses i)) + (accumulate [all2 (next (. clauses i)) + _ d (ipairs (. clauses i)) &until (not all2)] + (and all2 (or (not (sym? d)) (not (: (tostring d) :find "^&"))))))) + (values `(values ,(unpack val)) + (fcollect [i 1 (length clauses)] + (if (= 1 (% i 2)) + (list (unpack (. clauses i))) + (. clauses i)))) + (values val clauses))) + + (fn case-impl [match? init-val ...] "The shared implementation of case and match." - (assert (not= val nil) "missing subject") + (assert (not= init-val nil) "missing subject") (assert (= 0 (math.fmod (select :# ...) 2)) "expected even number of pattern/body pairs") (assert (not= 0 (select :# ...)) "expected at least one pattern/body pair") - (let [clauses [...] - vals (case-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] (case-condition vals clauses match?)))) + (let [(val clauses) (maybe-optimize-table init-val [...]) + vals-count (case-count-syms clauses) + skips-multiple-eval-protection? (and (= vals-count 1) (double-eval-safe? val))] + (if skips-multiple-eval-protection? + (case-condition (list val) clauses match? (table? init-val)) + ;; protect against multiple evaluation of the value, bind against as + ;; many values as we ever match against in the clauses. + (let [vals (fcollect [_ 1 vals-count &into (list)] (gensym))] + (list `let [vals val] (case-condition vals clauses match? (table? init-val))))))) (fn case* [val ...] "Perform pattern matching on val. See reference for details. @@ -6163,10 +6642,7 @@ do (case data-expression pattern body (where pattern guards*) body - (or pattern patterns*) body - (where (or pattern patterns*) guards*) body - ;; legacy: - (pattern ? guards*) body)" + (where (or pattern patterns*) guards*) body)" (case-impl false val ...)) (fn match* [val ...] @@ -6178,10 +6654,7 @@ do (match data-expression pattern body (where pattern guards*) body - (or pattern patterns*) body - (where (or pattern patterns*) guards*) body - ;; legacy: - (pattern ? guards*) body)" + (where (or pattern patterns*) guards*) body)" (case-impl true val ...)) (fn case-try-step [how expr else pattern body ...] @@ -6199,7 +6672,7 @@ do (fn case-try-impl [how expr pattern body ...] (let [clauses [pattern body ...] last (. clauses (length clauses)) - catch (if (= `catch (and (= :table (type last)) (. last 1))) + catch (if (sym? (and (= :table (type last)) (. last 1)) :catch) (let [[_ & e] (table.remove clauses)] e) ; remove `catch sym [`_# `...])] (assert (= 0 (math.fmod (length clauses) 2)) @@ -6238,7 +6711,7 @@ do :case-try case-try* :match match* :match-try match-try*} - ]===], {env = env, scope = compiler.scopes.compiler, allowedGlobals = false, useMetadata = true, filename = "src/fennel/match.fnl", moduleName = module_name}) + ]===], {allowedGlobals = false, env = env, filename = "src/fennel/match.fnl", moduleName = module_name, scope = compiler.scopes.compiler, useMetadata = true}) for k, v in pairs(match_macros) do compiler.scopes.global.macros[k] = v end