Upgrade to Fennel 0.9.2

This commit is contained in:
Jeremy Penner 2021-08-02 14:48:01 -04:00
parent ad219ba221
commit 5bf35209be

View file

@ -266,7 +266,7 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...)
else else
if parse_ok_3f then if parse_ok_3f then
do do
local _4_0, _5_0 = pcall(compiler.compile, x, {["assert-compile"] = opts["assert-compile"], ["parse-error"] = opts["parse-error"], correlate = opts.correlate, moduleName = opts.moduleName, scope = scope, source = src_string, useMetadata = opts.useMetadata}) local _4_0, _5_0 = pcall(compiler.compile, x, {["assert-compile"] = opts["assert-compile"], ["parse-error"] = opts["parse-error"], correlate = opts.correlate, moduleName = opts.moduleName, scope = scope, source = src_string, useBitLib = opts.useBitLib, useMetadata = opts.useMetadata})
if ((_4_0 == false) and (nil ~= _5_0)) then if ((_4_0 == false) and (nil ~= _5_0)) then
local msg = _5_0 local msg = _5_0
clear_stream() clear_stream()
@ -1202,6 +1202,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct
SPECIALS.each = function(ast, scope, parent) SPECIALS.each = function(ast, scope, parent)
compiler.assert((#ast >= 3), "expected body expression", ast[1]) compiler.assert((#ast >= 3), "expected body expression", ast[1])
local binding = compiler.assert(utils["table?"](ast[2]), "expected binding table", ast) 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 until_condition = remove_until_condition(binding)
local iter = table.remove(binding, #binding) local iter = table.remove(binding, #binding)
local destructures = {} local destructures = {}
@ -1876,7 +1877,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
else else
_0_ = 0 _0_ = 0
end end
return {autogensyms = {}, depth = _0_, hashfn = (parent0 and parent0.hashfn), includes = setmetatable({}, {__index = (parent0 and parent0.includes)}), macros = setmetatable({}, {__index = (parent0 and parent0.macros)}), manglings = setmetatable({}, {__index = (parent0 and parent0.manglings)}), parent = parent0, refedglobals = setmetatable({}, {__index = (parent0 and parent0.refedglobals)}), specials = setmetatable({}, {__index = (parent0 and parent0.specials)}), symmeta = setmetatable({}, {__index = (parent0 and parent0.symmeta)}), unmanglings = setmetatable({}, {__index = (parent0 and parent0.unmanglings)}), vararg = (parent0 and parent0.vararg)} return {autogensyms = setmetatable({}, {__index = (parent0 and parent0.autogensyms)}), depth = _0_, gensyms = setmetatable({}, {__index = (parent0 and parent0.gensyms)}), hashfn = (parent0 and parent0.hashfn), includes = setmetatable({}, {__index = (parent0 and parent0.includes)}), macros = setmetatable({}, {__index = (parent0 and parent0.macros)}), manglings = setmetatable({}, {__index = (parent0 and parent0.manglings)}), parent = parent0, refedglobals = setmetatable({}, {__index = (parent0 and parent0.refedglobals)}), specials = setmetatable({}, {__index = (parent0 and parent0.specials)}), symmeta = setmetatable({}, {__index = (parent0 and parent0.symmeta)}), unmanglings = setmetatable({}, {__index = (parent0 and parent0.unmanglings)}), vararg = (parent0 and parent0.vararg)}
end end
local function assert_msg(ast, msg) local function assert_msg(ast, msg)
local ast_tbl = nil local ast_tbl = nil
@ -1950,11 +1951,11 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
end end
end end
local allowed_globals = nil local allowed_globals = nil
local function global_allowed(name) local function global_allowed_3f(name)
return (not allowed_globals or utils["member?"](name, allowed_globals)) return (not allowed_globals or utils["member?"](name, allowed_globals))
end end
local function unique_mangling(original, mangling, scope, append) local function unique_mangling(original, mangling, scope, append)
if scope.unmanglings[mangling] then if (scope.unmanglings[mangling] and not scope.gensyms[mangling]) then
return unique_mangling(original, (original .. append), scope, (append + 1)) return unique_mangling(original, (original .. append), scope, (append + 1))
else else
return mangling return mangling
@ -2010,6 +2011,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
append = (append + 1) append = (append + 1)
end end
scope.unmanglings[mangling] = (base or true) scope.unmanglings[mangling] = (base or true)
scope.gensyms[mangling] = true
return mangling return mangling
end end
local function autogensym(base, scope) local function autogensym(base, scope)
@ -2068,7 +2070,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
if (local_3f and scope.symmeta[parts[1]]) then if (local_3f and scope.symmeta[parts[1]]) then
scope.symmeta[parts[1]]["used"] = true scope.symmeta[parts[1]]["used"] = true
end end
assert_compile((not reference_3f or local_3f or global_allowed(parts[1])), ("unknown global in strict mode: " .. tostring(parts[1])), symbol) assert_compile((not reference_3f or local_3f or ("_ENV" == parts[1]) or global_allowed_3f(parts[1])), ("unknown global in strict mode: " .. tostring(parts[1])), symbol)
if (allowed_globals and not local_3f) then if (allowed_globals and not local_3f) then
utils.root.scope.refedglobals[parts[1]] = true utils.root.scope.refedglobals[parts[1]] = true
end end
@ -2102,7 +2104,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
local m = getmetatable(ast) local m = getmetatable(ast)
return ((m and m.line and m) or (("table" == type(ast)) and ast) or {}) return ((m and m.line and m) or (("table" == type(ast)) and ast) or {})
end end
local function flatten_chunk_correlated(main_chunk) local function flatten_chunk_correlated(main_chunk, options)
local function flatten(chunk, out, last_line, file) local function flatten(chunk, out, last_line, file)
local last_line0 = last_line local last_line0 = last_line
if chunk.leaf then if chunk.leaf then
@ -2111,7 +2113,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
for _, subchunk in ipairs(chunk) do for _, subchunk in ipairs(chunk) do
if (subchunk.leaf or (#subchunk > 0)) then if (subchunk.leaf or (#subchunk > 0)) then
local source = ast_source(subchunk.ast) local source = ast_source(subchunk.ast)
if (file == source.file) then if (file == source.filename) then
last_line0 = math.max(last_line0, (source.line or 0)) last_line0 = math.max(last_line0, (source.line or 0))
end end
last_line0 = flatten(subchunk, out, last_line0, file) last_line0 = flatten(subchunk, out, last_line0, file)
@ -2121,7 +2123,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
return last_line0 return last_line0
end end
local out = {} local out = {}
local last = flatten(main_chunk, out, 1, main_chunk.file) local last = flatten(main_chunk, out, 1, options.filename)
for i = 1, last do for i = 1, last do
if (out[i] == nil) then if (out[i] == nil) then
out[i] = "" out[i] = ""
@ -2178,7 +2180,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
local function flatten(chunk, options) local function flatten(chunk, options)
local chunk0 = peephole(chunk) local chunk0 = peephole(chunk)
if options.correlate then if options.correlate then
return flatten_chunk_correlated(chunk0), {} return flatten_chunk_correlated(chunk0, options), {}
else else
local sm = {} local sm = {}
local ret = flatten_chunk(sm, chunk0, options.indent, 0) local ret = flatten_chunk(sm, chunk0, options.indent, 0)
@ -2222,20 +2224,21 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
local function exprs1(exprs) local function exprs1(exprs)
return table.concat(utils.map(exprs, 1), ", ") return table.concat(utils.map(exprs, 1), ", ")
end end
local function disambiguate_parens(code, chunk)
if (code:byte() == 40) then
return ("do end " .. code)
else
return code
end
end
local function keep_side_effects(exprs, chunk, start, ast) local function keep_side_effects(exprs, chunk, start, ast)
for j = (start or 1), #exprs do local start0 = (start or 1)
for j = start0, #exprs do
local se = exprs[j] local se = exprs[j]
if ((se.type == "expression") and (se[1] ~= "nil")) then if ((se.type == "expression") and (se[1] ~= "nil")) then
emit(chunk, string.format("do local _ = %s end", tostring(se)), ast) emit(chunk, string.format("do local _ = %s end", tostring(se)), ast)
elseif (se.type == "statement") then elseif (se.type == "statement") then
emit(chunk, disambiguate_parens(tostring(se), chunk), ast) local code = tostring(se)
local disambiguated = nil
if (code:byte() == 40) then
disambiguated = ("do end " .. code)
else
disambiguated = code
end
emit(chunk, disambiguated, ast)
end end
end end
return nil return nil
@ -2353,7 +2356,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
local function compile_function_call(ast, scope, parent, opts, compile1, len) local function compile_function_call(ast, scope, parent, opts, compile1, len)
local fargs = {} local fargs = {}
local fcallee = compile1(ast[1], scope, parent, {nval = 1})[1] local fcallee = compile1(ast[1], scope, parent, {nval = 1})[1]
assert_compile((fcallee.type ~= "literal"), ("cannot call literal value " .. tostring(ast[1])), ast) assert_compile((("string" == type(ast[1])) or (fcallee.type ~= "literal")), ("cannot call literal value " .. tostring(ast[1])), ast)
for i = 2, len do for i = 2, len do
local subexprs = nil local subexprs = nil
local _0_ local _0_
@ -2372,7 +2375,13 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
keep_side_effects(subexprs, parent, 2, ast[i]) keep_side_effects(subexprs, parent, 2, ast[i])
end end
end end
local call = string.format("%s(%s)", tostring(fcallee), exprs1(fargs)) local pat = nil
if ("string" == type(ast[1])) then
pat = "(%s)(%s)"
else
pat = "%s(%s)"
end
local call = string.format(pat, tostring(fcallee), exprs1(fargs))
return handle_compile_opts({utils.expr(call, "statement")}, parent, opts, ast) return handle_compile_opts({utils.expr(call, "statement")}, parent, opts, ast)
end end
local function compile_call(ast, scope, parent, opts, compile1) local function compile_call(ast, scope, parent, opts, compile1)
@ -2749,7 +2758,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct
end end
end end
local function traceback(msg, start) local function traceback(msg, start)
local msg0 = (msg or "") local msg0 = tostring((msg or ""))
if ((msg0:find("^Compile error") or msg0:find("^Parse error")) and not utils["debug-on?"]("trace")) then if ((msg0:find("^Compile error") or msg0:find("^Parse error")) and not utils["debug-on?"]("trace")) then
return msg0 return msg0
else else
@ -2888,7 +2897,7 @@ package.preload["fennel.friend"] = package.preload["fennel.friend"] or function(
local m = getmetatable(ast) local m = getmetatable(ast)
return ((m and m.line and m) or (("table" == type(ast)) and ast) or {}) return ((m and m.line and m) or (("table" == type(ast)) and ast) or {})
end end
local suggestions = {["$ and $... in hashfn are mutually exclusive"] = {"modifying the hashfn so it only contains $... or $, $1, $2, $3, etc"}, ["can't start multisym segment with a digit"] = {"removing the digit", "adding a non-digit before the digit"}, ["cannot call literal value"] = {"checking for typos", "checking for a missing function name"}, ["could not compile value of type "] = {"debugging the macro you're calling to return a list or table"}, ["could not read number (.*)"] = {"removing the non-digit character", "beginning the identifier with a non-digit if it is not meant to be a number"}, ["expected a function.* to call"] = {"removing the empty parentheses", "using square brackets if you want an empty table"}, ["expected binding table"] = {"placing a table here in square brackets containing identifiers to bind"}, ["expected body expression"] = {"putting some code in the body of this form after the bindings"}, ["expected each macro to be function"] = {"ensuring that the value for each key in your macros table contains a function", "avoid defining nested macro tables"}, ["expected even number of name/value bindings"] = {"finding where the identifier or value is missing"}, ["expected even number of values in table literal"] = {"removing a key", "adding a value"}, ["expected local"] = {"looking for a typo", "looking for a local which is used out of its scope"}, ["expected macros to be table"] = {"ensuring your macro definitions return a table"}, ["expected parameters"] = {"adding function parameters as a list of identifiers in brackets"}, ["expected rest argument before last parameter"] = {"moving & to right before the final identifier when destructuring"}, ["expected symbol for function parameter: (.*)"] = {"changing %s to an identifier instead of a literal value"}, ["expected var (.*)"] = {"declaring %s using var instead of let/local", "introducing a new local instead of changing the value of %s"}, ["expected vararg as last parameter"] = {"moving the \"...\" to the end of the parameter list"}, ["expected whitespace before opening delimiter"] = {"adding whitespace"}, ["global (.*) conflicts with local"] = {"renaming local %s"}, ["illegal character: (.)"] = {"deleting or replacing %s", "avoiding reserved characters like \", \\, ', ~, ;, @, `, and comma"}, ["local (.*) was overshadowed by a special form or macro"] = {"renaming local %s"}, ["macro not found in macro module"] = {"checking the keys of the imported macro module's returned table"}, ["macro tried to bind (.*) without gensym"] = {"changing to %s# when introducing identifiers inside macros"}, ["malformed multisym"] = {"ensuring each period or colon is not followed by another period or colon"}, ["may only be used at compile time"] = {"moving this to inside a macro if you need to manipulate symbols/lists", "using square brackets instead of parens to construct a table"}, ["method must be last component"] = {"using a period instead of a colon for field access", "removing segments after the colon", "making the method call, then looking up the field on the result"}, ["mismatched closing delimiter (.), expected (.)"] = {"replacing %s with %s", "deleting %s", "adding matching opening delimiter earlier"}, ["multisym method calls may only be in call position"] = {"using a period instead of a colon to reference a table's fields", "putting parens around this"}, ["unable to bind (.*)"] = {"replacing the %s with an identifier"}, ["unexpected closing delimiter (.)"] = {"deleting %s", "adding matching opening delimiter earlier"}, ["unexpected multi symbol (.*)"] = {"removing periods or colons from %s"}, ["unexpected vararg"] = {"putting \"...\" at the end of the fn parameters if the vararg was intended"}, ["unknown global in strict mode: (.*)"] = {"looking to see if there's a typo", "using the _G table instead, eg. _G.%s if you really want a global", "moving this code to somewhere that %s is in scope", "binding %s as a local in the scope of this code"}, ["unused local (.*)"] = {"fixing a typo so %s is used", "renaming the local to _%s"}, ["use of global (.*) is aliased by a local"] = {"renaming local %s", "refer to the global using _G.%s instead of directly"}} local suggestions = {["$ and $... in hashfn are mutually exclusive"] = {"modifying the hashfn so it only contains $... or $, $1, $2, $3, etc"}, ["can't start multisym segment with a digit"] = {"removing the digit", "adding a non-digit before the digit"}, ["cannot call literal value"] = {"checking for typos", "checking for a missing function name"}, ["could not compile value of type "] = {"debugging the macro you're calling to return a list or table"}, ["could not read number (.*)"] = {"removing the non-digit character", "beginning the identifier with a non-digit if it is not meant to be a number"}, ["expected a function.* to call"] = {"removing the empty parentheses", "using square brackets if you want an empty table"}, ["expected binding and iterator"] = {"making sure you haven't omitted a local name or iterator"}, ["expected binding table"] = {"placing a table here in square brackets containing identifiers to bind"}, ["expected body expression"] = {"putting some code in the body of this form after the bindings"}, ["expected each macro to be function"] = {"ensuring that the value for each key in your macros table contains a function", "avoid defining nested macro tables"}, ["expected even number of name/value bindings"] = {"finding where the identifier or value is missing"}, ["expected even number of values in table literal"] = {"removing a key", "adding a value"}, ["expected local"] = {"looking for a typo", "looking for a local which is used out of its scope"}, ["expected macros to be table"] = {"ensuring your macro definitions return a table"}, ["expected parameters"] = {"adding function parameters as a list of identifiers in brackets"}, ["expected rest argument before last parameter"] = {"moving & to right before the final identifier when destructuring"}, ["expected symbol for function parameter: (.*)"] = {"changing %s to an identifier instead of a literal value"}, ["expected var (.*)"] = {"declaring %s using var instead of let/local", "introducing a new local instead of changing the value of %s"}, ["expected vararg as last parameter"] = {"moving the \"...\" to the end of the parameter list"}, ["expected whitespace before opening delimiter"] = {"adding whitespace"}, ["global (.*) conflicts with local"] = {"renaming local %s"}, ["illegal character: (.)"] = {"deleting or replacing %s", "avoiding reserved characters like \", \\, ', ~, ;, @, `, and comma"}, ["local (.*) was overshadowed by a special form or macro"] = {"renaming local %s"}, ["macro not found in macro module"] = {"checking the keys of the imported macro module's returned table"}, ["macro tried to bind (.*) without gensym"] = {"changing to %s# when introducing identifiers inside macros"}, ["malformed multisym"] = {"ensuring each period or colon is not followed by another period or colon"}, ["may only be used at compile time"] = {"moving this to inside a macro if you need to manipulate symbols/lists", "using square brackets instead of parens to construct a table"}, ["method must be last component"] = {"using a period instead of a colon for field access", "removing segments after the colon", "making the method call, then looking up the field on the result"}, ["mismatched closing delimiter (.), expected (.)"] = {"replacing %s with %s", "deleting %s", "adding matching opening delimiter earlier"}, ["multisym method calls may only be in call position"] = {"using a period instead of a colon to reference a table's fields", "putting parens around this"}, ["unable to bind (.*)"] = {"replacing the %s with an identifier"}, ["unexpected closing delimiter (.)"] = {"deleting %s", "adding matching opening delimiter earlier"}, ["unexpected multi symbol (.*)"] = {"removing periods or colons from %s"}, ["unexpected vararg"] = {"putting \"...\" at the end of the fn parameters if the vararg was intended"}, ["unknown global in strict mode: (.*)"] = {"looking to see if there's a typo", "using the _G table instead, eg. _G.%s if you really want a global", "moving this code to somewhere that %s is in scope", "binding %s as a local in the scope of this code"}, ["unused local (.*)"] = {"fixing a typo so %s is used", "renaming the local to _%s"}, ["use of global (.*) is aliased by a local"] = {"renaming local %s", "refer to the global using _G.%s instead of directly"}}
local unpack = (table.unpack or _G.unpack) local unpack = (table.unpack or _G.unpack)
local function suggest(msg) local function suggest(msg)
local suggestion = nil local suggestion = nil
@ -3706,19 +3715,19 @@ local function dofile_2a(filename, options, ...)
opts.filename = filename opts.filename = filename
return eval(source, opts, ...) return eval(source, opts, ...)
end end
local mod = {["comment?"] = utils["comment?"], ["compile-stream"] = compiler["compile-stream"], ["compile-string"] = compiler["compile-string"], ["list?"] = utils["list?"], ["load-code"] = specials["load-code"], ["macro-loaded"] = specials["macro-loaded"], ["macro-searchers"] = specials["macro-searchers"], ["make-searcher"] = specials["make-searcher"], ["search-module"] = specials["search-module"], ["sequence?"] = utils["sequence?"], ["string-stream"] = parser["string-stream"], ["sym-char?"] = parser["sym-char?"], ["sym?"] = utils["sym?"], comment = utils.comment, compile = compiler.compile, compile1 = compiler.compile1, compileStream = compiler["compile-stream"], compileString = compiler["compile-string"], doc = specials.doc, dofile = dofile_2a, eval = eval, gensym = compiler.gensym, granulate = parser.granulate, list = utils.list, loadCode = specials["load-code"], macroLoaded = specials["macro-loaded"], makeSearcher = specials["make-searcher"], make_searcher = specials["make-searcher"], mangle = compiler["global-mangling"], metadata = compiler.metadata, parser = parser.parser, path = utils.path, repl = repl, scope = compiler["make-scope"], searchModule = specials["search-module"], searcher = specials["make-searcher"](), sequence = utils.sequence, stringStream = parser["string-stream"], sym = utils.sym, traceback = compiler.traceback, unmangle = compiler["global-unmangling"], varg = utils.varg, version = "0.9.1-dev", view = view} local mod = {["comment?"] = utils["comment?"], ["compile-stream"] = compiler["compile-stream"], ["compile-string"] = compiler["compile-string"], ["list?"] = utils["list?"], ["load-code"] = specials["load-code"], ["macro-loaded"] = specials["macro-loaded"], ["macro-searchers"] = specials["macro-searchers"], ["make-searcher"] = specials["make-searcher"], ["search-module"] = specials["search-module"], ["sequence?"] = utils["sequence?"], ["string-stream"] = parser["string-stream"], ["sym-char?"] = parser["sym-char?"], ["sym?"] = utils["sym?"], comment = utils.comment, compile = compiler.compile, compile1 = compiler.compile1, compileStream = compiler["compile-stream"], compileString = compiler["compile-string"], doc = specials.doc, dofile = dofile_2a, eval = eval, gensym = compiler.gensym, granulate = parser.granulate, list = utils.list, loadCode = specials["load-code"], macroLoaded = specials["macro-loaded"], makeSearcher = specials["make-searcher"], make_searcher = specials["make-searcher"], mangle = compiler["global-mangling"], metadata = compiler.metadata, parser = parser.parser, path = utils.path, repl = repl, scope = compiler["make-scope"], searchModule = specials["search-module"], searcher = specials["make-searcher"](), sequence = utils.sequence, stringStream = parser["string-stream"], sym = utils.sym, traceback = compiler.traceback, unmangle = compiler["global-unmangling"], varg = utils.varg, version = "0.9.2", view = view}
utils["fennel-module"] = mod utils["fennel-module"] = mod
do do
local builtin_macros = [===[;; This module contains all the built-in Fennel macros. Unlike all the other local builtin_macros = [===[;; This module contains all the built-in Fennel macros. Unlike all the other
;; modules that are loaded by the old bootstrap compiler, this runs in the ;; modules that are loaded by the old bootstrap compiler, this runs in the
;; compiler scope of the version of the compiler being defined. ;; compiler scope of the version of the compiler being defined.
;; The code for these macros is somewhat idiosyncratic because it cannot use any ;; The code for these macros is somewhat idiosyncratic because it cannot use any
;; macros which have not yet been defined. ;; macros which have not yet been defined.
;; TODO: some of these macros modify their arguments; we should stop doing that, ;; TODO: some of these macros modify their arguments; we should stop doing that,
;; but in a way that preserves file/line metadata. ;; but in a way that preserves file/line metadata.
(fn ->* [val ...] (fn ->* [val ...]
"Thread-first macro. "Thread-first macro.
Take the first value and splice it into the second form as its first argument. Take the first value and splice it into the second form as its first argument.
@ -3729,7 +3738,7 @@ do
(table.insert elt 2 x) (table.insert elt 2 x)
(set x elt))) (set x elt)))
x) x)
(fn ->>* [val ...] (fn ->>* [val ...]
"Thread-last macro. "Thread-last macro.
Same as ->, except splices the value into the last position of each form Same as ->, except splices the value into the last position of each form
@ -3740,7 +3749,7 @@ do
(table.insert elt x) (table.insert elt x)
(set x elt))) (set x elt)))
x) x)
(fn -?>* [val ...] (fn -?>* [val ...]
"Nil-safe thread-first macro. "Nil-safe thread-first macro.
Same as -> except will short-circuit with nil when it encounters a nil value." Same as -> except will short-circuit with nil when it encounters a nil value."
@ -3755,7 +3764,7 @@ do
(if ,tmp (if ,tmp
(-?> ,el ,(unpack els)) (-?> ,el ,(unpack els))
,tmp))))) ,tmp)))))
(fn -?>>* [val ...] (fn -?>>* [val ...]
"Nil-safe thread-last macro. "Nil-safe thread-last macro.
Same as ->> except will short-circuit with nil when it encounters a nil value." Same as ->> except will short-circuit with nil when it encounters a nil value."
@ -3770,14 +3779,20 @@ do
(if ,tmp (if ,tmp
(-?>> ,el ,(unpack els)) (-?>> ,el ,(unpack els))
,tmp))))) ,tmp)))))
(fn ?dot [tbl k ...] (fn ?dot [tbl ...]
"Nil-safe table look up. "Nil-safe table look up.
Same as . (dot), except will short-circuit with nil when it encounters Same as . (dot), except will short-circuit with nil when it encounters
a nil value in any of subsequent keys." a nil value in any of subsequent keys."
(if (= nil k) tbl `(let [res# (. ,tbl ,k)] (let [head (gensym :t)
(and res# (?. res# ,...))))) lookups `(do (var ,head ,tbl) ,head)]
(each [_ k (ipairs [...])]
;; Kinda gnarly to reassign in place like this, but it emits the best lua.
;; With this impl, it emits a flat, concise, and readable set of if blocks.
(table.insert lookups (# lookups) `(if (not= nil ,head)
(set ,head (. ,head ,k)))))
lookups))
(fn doto* [val ...] (fn doto* [val ...]
"Evaluates val and splices it into the first argument of subsequent forms." "Evaluates val and splices it into the first argument of subsequent forms."
(let [name (gensym) (let [name (gensym)
@ -3787,7 +3802,7 @@ do
(table.insert form elt)) (table.insert form elt))
(table.insert form name) (table.insert form name)
form)) form))
(fn when* [condition body1 ...] (fn when* [condition body1 ...]
"Evaluate body for side-effects only when condition is truthy." "Evaluate body for side-effects only when condition is truthy."
(assert body1 "expected body") (assert body1 "expected body")
@ -3795,7 +3810,7 @@ do
(do (do
,body1 ,body1
,...))) ,...)))
(fn with-open* [closable-bindings ...] (fn with-open* [closable-bindings ...]
"Like `let`, but invokes (v:close) on each binding after evaluating the body. "Like `let`, but invokes (v:close) on each binding after evaluating the body.
The body is evaluated inside `xpcall` so that bound values will be closed upon The body is evaluated inside `xpcall` so that bound values will be closed upon
@ -3812,13 +3827,13 @@ do
`(let ,closable-bindings `(let ,closable-bindings
,closer ,closer
(close-handlers# (xpcall ,bodyfn ,traceback))))) (close-handlers# (xpcall ,bodyfn ,traceback)))))
(fn collect* [iter-tbl key-value-expr ...] (fn collect* [iter-tbl key-value-expr ...]
"Returns a table made by running an iterator and evaluating an expression "Returns a table made by running an iterator and evaluating an expression
that returns key-value pairs to be inserted sequentially into the table. that returns key-value pairs to be inserted sequentially into the table.
This can be thought of as a \"table comprehension\". The provided key-value This can be thought of as a \"table comprehension\". The provided key-value
expression must return either 2 values, or nil. expression must return either 2 values, or nil.
For example, For example,
(collect [k v (pairs {:apple \"red\" :orange \"orange\"})] (collect [k v (pairs {:apple \"red\" :orange \"orange\"})]
(values v k)) (values v k))
@ -3834,12 +3849,12 @@ do
(match ,key-value-expr (match ,key-value-expr
(k# v#) (tset tbl# k# v#))) (k# v#) (tset tbl# k# v#)))
tbl#)) tbl#))
(fn icollect* [iter-tbl value-expr ...] (fn icollect* [iter-tbl value-expr ...]
"Returns a sequential table made by running an iterator and evaluating an "Returns a sequential table made by running an iterator and evaluating an
expression that returns values to be inserted sequentially into the table. expression that returns values to be inserted sequentially into the table.
This can be thought of as a \"list comprehension\". This can be thought of as a \"list comprehension\".
For example, For example,
(icollect [_ v (ipairs [1 2 3 4 5])] (when (> v 2) (* v v))) (icollect [_ v (ipairs [1 2 3 4 5])] (when (> v 2) (* v v)))
returns returns
@ -3853,7 +3868,7 @@ do
(each ,iter-tbl (each ,iter-tbl
(tset tbl# (+ (length tbl#) 1) ,value-expr)) (tset tbl# (+ (length tbl#) 1) ,value-expr))
tbl#)) tbl#))
(fn partial* [f ...] (fn partial* [f ...]
"Returns a function with all arguments partially applied to f." "Returns a function with all arguments partially applied to f."
(assert f "expected a function to partially apply") (assert f "expected a function to partially apply")
@ -3861,10 +3876,10 @@ do
(table.insert body _VARARG) (table.insert body _VARARG)
`(fn [,_VARARG] `(fn [,_VARARG]
,body))) ,body)))
(fn pick-args* [n f] (fn pick-args* [n f]
"Creates a function of arity n that applies its arguments to f. "Creates a function of arity n that applies its arguments to f.
For example, For example,
(pick-args 2 func) (pick-args 2 func)
expands to expands to
@ -3876,10 +3891,10 @@ do
(tset bindings i (gensym))) (tset bindings i (gensym)))
`(fn ,bindings `(fn ,bindings
(,f ,(unpack bindings))))) (,f ,(unpack bindings)))))
(fn pick-values* [n ...] (fn pick-values* [n ...]
"Like the `values` special, but emits exactly n values. "Like the `values` special, but emits exactly n values.
For example, For example,
(pick-values 2 ...) (pick-values 2 ...)
expands to expands to
@ -3894,7 +3909,7 @@ do
(if (= n 0) `(values) (if (= n 0) `(values)
`(let [,let-syms ,let-values] `(let [,let-syms ,let-values]
(values ,(unpack let-syms)))))) (values ,(unpack let-syms))))))
(fn lambda* [...] (fn lambda* [...]
"Function literal with arity checking. "Function literal with arity checking.
Will throw an exception if a declared argument is passed in as nil, unless Will throw an exception if a declared argument is passed in as nil, unless
@ -3921,26 +3936,26 @@ do
,(tostring a) ,(tostring a)
,(or a.filename :unknown) ,(or a.filename :unknown)
,(or a.line "?")))))) ,(or a.line "?"))))))
(assert (= :table (type arglist)) "expected arg list") (assert (= :table (type arglist)) "expected arg list")
(each [_ a (ipairs arglist)] (each [_ a (ipairs arglist)]
(check! a)) (check! a))
(if empty-body? (if empty-body?
(table.insert args (sym :nil))) (table.insert args (sym :nil)))
`(fn ,(unpack args)))) `(fn ,(unpack args))))
(fn macro* [name ...] (fn macro* [name ...]
"Define a single macro." "Define a single macro."
(assert (sym? name) "expected symbol for macro name") (assert (sym? name) "expected symbol for macro name")
(local args [...]) (local args [...])
`(macros {,(tostring name) (fn ,(unpack args))})) `(macros {,(tostring name) (fn ,(unpack args))}))
(fn macrodebug* [form return?] (fn macrodebug* [form return?]
"Print the resulting form after performing macroexpansion. "Print the resulting form after performing macroexpansion.
With a second argument, returns expanded form as a string instead of printing." With a second argument, returns expanded form as a string instead of printing."
(let [handle (if return? `do `print)] (let [handle (if return? `do `print)]
`(,handle ,(view (macroexpand form _SCOPE))))) `(,handle ,(view (macroexpand form _SCOPE)))))
(fn import-macros* [binding1 module-name1 ...] (fn import-macros* [binding1 module-name1 ...]
"Binds a table of macros from each macro module according to a binding form. "Binds a table of macros from each macro module according to a binding form.
Each binding form can be either a symbol or a k/v destructuring table. Each binding form can be either a symbol or a k/v destructuring table.
@ -3971,9 +3986,9 @@ do
(tostring modname))) (tostring modname)))
(tset scope.macros import-key (. subscope.macros macro-name)))))) (tset scope.macros import-key (. subscope.macros macro-name))))))
nil) nil)
;;; Pattern matching ;;; Pattern matching
(fn match-values [vals pattern unifications match-pattern] (fn match-values [vals pattern unifications match-pattern]
(let [condition `(and) (let [condition `(and)
bindings []] bindings []]
@ -3984,7 +3999,7 @@ do
(each [_ b (ipairs subbindings)] (each [_ b (ipairs subbindings)]
(table.insert bindings b)))) (table.insert bindings b))))
(values condition bindings))) (values condition bindings)))
(fn match-table [val pattern unifications match-pattern] (fn match-table [val pattern unifications match-pattern]
(let [condition `(and (= (type ,val) :table)) (let [condition `(and (= (type ,val) :table))
bindings []] bindings []]
@ -4016,7 +4031,7 @@ do
(each [_ b (ipairs subbindings)] (each [_ b (ipairs subbindings)]
(table.insert bindings b))))) (table.insert bindings b)))))
(values condition bindings))) (values condition bindings)))
(fn match-pattern [vals pattern unifications] (fn match-pattern [vals pattern unifications]
"Takes the AST of values and a single pattern and returns a condition "Takes the AST of values and a single pattern and returns a condition
to determine if it matches as well as a list of bindings to to determine if it matches as well as a list of bindings to
@ -4043,11 +4058,10 @@ do
(and (list? pattern) (= (. pattern 2) `?)) (and (list? pattern) (= (. pattern 2) `?))
(let [(pcondition bindings) (match-pattern vals (. pattern 1) (let [(pcondition bindings) (match-pattern vals (. pattern 1)
unifications) unifications)
condition `(and ,pcondition)] condition `(and ,(unpack pattern 3))]
(for [i 3 (length pattern)] ; splice in guard clauses (values `(and ,pcondition
(table.insert condition (. pattern i))) (let ,bindings
(values `(let ,bindings ,condition)) bindings))
,condition) bindings))
;; multi-valued patterns (represented as lists) ;; multi-valued patterns (represented as lists)
(list? pattern) (list? pattern)
(match-values vals pattern unifications match-pattern) (match-values vals pattern unifications match-pattern)
@ -4056,7 +4070,7 @@ do
(match-table val pattern unifications match-pattern) (match-table val pattern unifications match-pattern)
;; literal value ;; literal value
(values `(= ,val ,pattern) [])))) (values `(= ,val ,pattern) []))))
(fn match-condition [vals clauses] (fn match-condition [vals clauses]
"Construct the actual `if` AST for the given match values and clauses." "Construct the actual `if` AST for the given match values and clauses."
(if (not= 0 (% (length clauses) 2)) ; treat odd final clause as default (if (not= 0 (% (length clauses) 2)) ; treat odd final clause as default
@ -4070,17 +4084,20 @@ do
(table.insert out `(let ,bindings (table.insert out `(let ,bindings
,body)))) ,body))))
out)) out))
(fn match-val-syms [clauses] (fn match-val-syms [clauses]
"How many multi-valued clauses are there? return a list of that many gensyms." "How many multi-valued clauses are there? return a list of that many gensyms."
(let [syms (list (gensym))] (let [syms (list (gensym))]
(for [i 1 (length clauses) 2] (for [i 1 (length clauses) 2]
(if (list? (. clauses i)) (let [clause (if (and (list? (. clauses i)) (= `? (. clauses i 2)))
(each [valnum (ipairs (. clauses i))] (. clauses i 1)
(if (not (. syms valnum)) (. clauses i))]
(tset syms valnum (gensym)))))) (if (list? clause)
(each [valnum (ipairs clause)]
(if (not (. syms valnum))
(tset syms valnum (gensym)))))))
syms)) syms))
(fn match* [val ...] (fn match* [val ...]
;; Old implementation of match macro, which doesn't directly support ;; Old implementation of match macro, which doesn't directly support
;; `where' and `or'. New syntax is implemented in `match-where', ;; `where' and `or'. New syntax is implemented in `match-where',
@ -4090,9 +4107,9 @@ do
;; protect against multiple evaluation of the value, bind against as ;; protect against multiple evaluation of the value, bind against as
;; many values as we ever match against in the clauses. ;; many values as we ever match against in the clauses.
(list `let [vals val] (match-condition vals clauses)))) (list `let [vals val] (match-condition vals clauses))))
;; Construction of old match syntax from new syntax ;; Construction of old match syntax from new syntax
(fn partition-2 [seq] (fn partition-2 [seq]
;; Partition `seq` by 2. ;; Partition `seq` by 2.
;; If `seq` has odd amount of elements, the last one is dropped. ;; If `seq` has odd amount of elements, the last one is dropped.
@ -4112,7 +4129,7 @@ do
(if (not= nil v2) (if (not= nil v2)
(table.insert res [v1 v2])))) (table.insert res [v1 v2]))))
res)) res))
(fn transform-or [[_ & pats] guards] (fn transform-or [[_ & pats] guards]
;; Transforms `(or pat pats*)` lists into match `guard` patterns. ;; Transforms `(or pat pats*)` lists into match `guard` patterns.
;; ;;
@ -4121,7 +4138,7 @@ do
(each [_ pat (ipairs pats)] (each [_ pat (ipairs pats)]
(table.insert res (list pat `? (unpack guards)))) (table.insert res (list pat `? (unpack guards))))
res)) res))
(fn transform-cond [cond] (fn transform-cond [cond]
;; Transforms `where` cond into sequence of `match` guards. ;; Transforms `where` cond into sequence of `match` guards.
;; ;;
@ -4136,12 +4153,12 @@ do
[(list second `? (unpack cond 3))])) [(list second `? (unpack cond 3))]))
:else :else
[cond])) [cond]))
(fn match-where [val ...] (fn match-where [val ...]
"Perform pattern matching on val. See reference for details. "Perform pattern matching on val. See reference for details.
Syntax: Syntax:
(match data-expression (match data-expression
pattern body pattern body
(where pattern guard guards*) body (where pattern guard guards*) body
@ -4157,7 +4174,7 @@ do
(if else-branch (if else-branch
(table.insert match-body else-branch)) (table.insert match-body else-branch))
(match* val (unpack match-body)))) (match* val (unpack match-body))))
{:-> ->* {:-> ->*
:->> ->>* :->> ->>*
:-?> -?>* :-?> -?>*